htypechk.pas 35 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992
  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. get_para_resulttype : boolean = false;
  26. allow_array_constructor : boolean = false;
  27. { Conversion }
  28. function isconvertable(def_from,def_to : pdef;
  29. var doconv : tconverttype;fromtreetype : ttreetyp;
  30. explicit : boolean) : byte;
  31. { Register Allocation }
  32. procedure make_not_regable(p : ptree);
  33. procedure left_right_max(p : ptree);
  34. procedure calcregisters(p : ptree;r32,fpu,mmx : word);
  35. { subroutine handling }
  36. procedure test_protected_sym(sym : psym);
  37. procedure test_protected(p : ptree);
  38. function valid_for_formal_var(p : ptree) : boolean;
  39. function valid_for_formal_const(p : ptree) : boolean;
  40. function is_procsym_load(p:Ptree):boolean;
  41. function is_procsym_call(p:Ptree):boolean;
  42. function assignment_overloaded(from_def,to_def : pdef) : pprocdef;
  43. procedure test_local_to_procvar(from_def:pprocvardef;to_def:pdef);
  44. function valid_for_assign(p:ptree;allowprop:boolean):boolean;
  45. implementation
  46. uses
  47. globtype,systems,tokens,
  48. cobjects,verbose,globals,
  49. symconst,
  50. types,
  51. {$ifdef newcg}
  52. cgbase
  53. {$else}
  54. hcodegen
  55. {$endif}
  56. ;
  57. {****************************************************************************
  58. Convert
  59. ****************************************************************************}
  60. { Returns:
  61. 0 - Not convertable
  62. 1 - Convertable
  63. 2 - Convertable, but not first choice }
  64. function isconvertable(def_from,def_to : pdef;
  65. var doconv : tconverttype;fromtreetype : ttreetyp;
  66. explicit : boolean) : byte;
  67. { Tbasetype: uauto,uvoid,uchar,
  68. u8bit,u16bit,u32bit,
  69. s8bit,s16bit,s32,
  70. bool8bit,bool16bit,bool32bit,
  71. u64bit,s64bitint }
  72. type
  73. tbasedef=(bvoid,bchar,bint,bbool);
  74. const
  75. basedeftbl:array[tbasetype] of tbasedef =
  76. (bvoid,bvoid,bchar,
  77. bint,bint,bint,
  78. bint,bint,bint,
  79. bbool,bbool,bbool,bint,bint);
  80. basedefconverts : array[tbasedef,tbasedef] of tconverttype =
  81. ((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible),
  82. (tc_not_possible,tc_equal,tc_not_possible,tc_not_possible),
  83. (tc_not_possible,tc_not_possible,tc_int_2_int,tc_int_2_bool),
  84. (tc_not_possible,tc_not_possible,tc_bool_2_int,tc_bool_2_bool));
  85. var
  86. b : byte;
  87. hd1,hd2 : pdef;
  88. hct : tconverttype;
  89. begin
  90. { safety check }
  91. if not(assigned(def_from) and assigned(def_to)) then
  92. begin
  93. isconvertable:=0;
  94. exit;
  95. end;
  96. { tp7 procvar def support, in tp7 a procvar is always called, if the
  97. procvar is passed explicit a addrn would be there }
  98. if (m_tp_procvar in aktmodeswitches) and
  99. (def_from^.deftype=procvardef) and
  100. (fromtreetype=loadn) then
  101. begin
  102. def_from:=pprocvardef(def_from)^.retdef;
  103. end;
  104. { we walk the wanted (def_to) types and check then the def_from
  105. types if there is a conversion possible }
  106. b:=0;
  107. case def_to^.deftype of
  108. orddef :
  109. begin
  110. case def_from^.deftype of
  111. orddef :
  112. begin
  113. doconv:=basedefconverts[basedeftbl[porddef(def_from)^.typ],basedeftbl[porddef(def_to)^.typ]];
  114. b:=1;
  115. if (doconv=tc_not_possible) or
  116. ((doconv=tc_int_2_bool) and
  117. (not explicit) and
  118. (not is_boolean(def_from))) or
  119. ((doconv=tc_bool_2_int) and
  120. (not explicit) and
  121. (not is_boolean(def_to))) then
  122. b:=0;
  123. end;
  124. enumdef :
  125. begin
  126. { needed for char(enum) }
  127. if explicit then
  128. begin
  129. doconv:=tc_int_2_int;
  130. b:=1;
  131. end;
  132. end;
  133. end;
  134. end;
  135. stringdef :
  136. begin
  137. case def_from^.deftype of
  138. stringdef :
  139. begin
  140. doconv:=tc_string_2_string;
  141. b:=1;
  142. end;
  143. orddef :
  144. begin
  145. { char to string}
  146. if is_char(def_from) then
  147. begin
  148. doconv:=tc_char_2_string;
  149. b:=1;
  150. end;
  151. end;
  152. arraydef :
  153. begin
  154. { array of char to string, the length check is done by the firstpass of this node }
  155. if is_chararray(def_from) then
  156. begin
  157. doconv:=tc_chararray_2_string;
  158. if (not(cs_ansistrings in aktlocalswitches) and
  159. is_shortstring(def_to)) or
  160. ((cs_ansistrings in aktlocalswitches) and
  161. is_ansistring(def_to)) then
  162. b:=1
  163. else
  164. b:=2;
  165. end;
  166. end;
  167. pointerdef :
  168. begin
  169. { pchar can be assigned to short/ansistrings }
  170. if is_pchar(def_from) and not(m_tp in aktmodeswitches) then
  171. begin
  172. doconv:=tc_pchar_2_string;
  173. b:=1;
  174. end;
  175. end;
  176. end;
  177. end;
  178. floatdef :
  179. begin
  180. case def_from^.deftype of
  181. orddef :
  182. begin { ordinal to real }
  183. if is_integer(def_from) then
  184. begin
  185. if pfloatdef(def_to)^.typ=f32bit then
  186. doconv:=tc_int_2_fix
  187. else
  188. doconv:=tc_int_2_real;
  189. b:=1;
  190. end;
  191. end;
  192. floatdef :
  193. begin { 2 float types ? }
  194. if pfloatdef(def_from)^.typ=pfloatdef(def_to)^.typ then
  195. doconv:=tc_equal
  196. else
  197. begin
  198. if pfloatdef(def_from)^.typ=f32bit then
  199. doconv:=tc_fix_2_real
  200. else
  201. if pfloatdef(def_to)^.typ=f32bit then
  202. doconv:=tc_real_2_fix
  203. else
  204. doconv:=tc_real_2_real;
  205. end;
  206. b:=1;
  207. end;
  208. end;
  209. end;
  210. enumdef :
  211. begin
  212. if (def_from^.deftype=enumdef) then
  213. begin
  214. if assigned(penumdef(def_from)^.basedef) then
  215. hd1:=penumdef(def_from)^.basedef
  216. else
  217. hd1:=def_from;
  218. if assigned(penumdef(def_to)^.basedef) then
  219. hd2:=penumdef(def_to)^.basedef
  220. else
  221. hd2:=def_to;
  222. if (hd1=hd2) then
  223. b:=1;
  224. end;
  225. end;
  226. arraydef :
  227. begin
  228. { open array is also compatible with a single element of its base type }
  229. if is_open_array(def_to) and
  230. is_equal(parraydef(def_to)^.definition,def_from) then
  231. begin
  232. doconv:=tc_equal;
  233. b:=1;
  234. end
  235. else
  236. begin
  237. case def_from^.deftype of
  238. arraydef :
  239. begin
  240. { array constructor -> open array }
  241. if is_open_array(def_to) and
  242. is_array_constructor(def_from) then
  243. begin
  244. if is_equal(parraydef(def_to)^.definition,parraydef(def_from)^.definition) then
  245. begin
  246. doconv:=tc_equal;
  247. b:=1;
  248. end
  249. else
  250. if isconvertable(parraydef(def_to)^.definition,
  251. parraydef(def_from)^.definition,hct,nothingn,false)<>0 then
  252. begin
  253. doconv:=hct;
  254. b:=2;
  255. end;
  256. end;
  257. end;
  258. pointerdef :
  259. begin
  260. if is_zero_based_array(def_to) and
  261. is_equal(ppointerdef(def_from)^.definition,parraydef(def_to)^.definition) then
  262. begin
  263. doconv:=tc_pointer_2_array;
  264. b:=1;
  265. end;
  266. end;
  267. stringdef :
  268. begin
  269. { string to array of char}
  270. if (not(is_special_array(def_to)) or is_open_array(def_to)) and
  271. is_equal(parraydef(def_to)^.definition,cchardef) then
  272. begin
  273. doconv:=tc_string_2_chararray;
  274. b:=1;
  275. end;
  276. end;
  277. end;
  278. end;
  279. end;
  280. pointerdef :
  281. begin
  282. case def_from^.deftype of
  283. stringdef :
  284. begin
  285. { string constant to zero terminated string constant }
  286. if (fromtreetype=stringconstn) and
  287. is_pchar(def_to) then
  288. begin
  289. doconv:=tc_cstring_2_pchar;
  290. b:=1;
  291. end;
  292. end;
  293. orddef :
  294. begin
  295. { char constant to zero terminated string constant }
  296. if (fromtreetype=ordconstn) then
  297. begin
  298. if is_equal(def_from,cchardef) and
  299. is_pchar(def_to) then
  300. begin
  301. doconv:=tc_cchar_2_pchar;
  302. b:=1;
  303. end
  304. else
  305. if is_integer(def_from) then
  306. begin
  307. doconv:=tc_cord_2_pointer;
  308. b:=1;
  309. end;
  310. end;
  311. end;
  312. arraydef :
  313. begin
  314. { chararray to pointer }
  315. if is_zero_based_array(def_from) and
  316. is_equal(parraydef(def_from)^.definition,ppointerdef(def_to)^.definition) then
  317. begin
  318. doconv:=tc_array_2_pointer;
  319. b:=1;
  320. end;
  321. end;
  322. pointerdef :
  323. begin
  324. { child class pointer can be assigned to anchestor pointers }
  325. if (
  326. (ppointerdef(def_from)^.definition^.deftype=objectdef) and
  327. (ppointerdef(def_to)^.definition^.deftype=objectdef) and
  328. pobjectdef(ppointerdef(def_from)^.definition)^.is_related(
  329. pobjectdef(ppointerdef(def_to)^.definition))
  330. ) or
  331. { all pointers can be assigned to void-pointer }
  332. is_equal(ppointerdef(def_to)^.definition,voiddef) or
  333. { in my opnion, is this not clean pascal }
  334. { well, but it's handy to use, it isn't ? (FK) }
  335. is_equal(ppointerdef(def_from)^.definition,voiddef) then
  336. begin
  337. doconv:=tc_equal;
  338. b:=1;
  339. end;
  340. end;
  341. procvardef :
  342. begin
  343. { procedure variable can be assigned to an void pointer }
  344. { Not anymore. Use the @ operator now.}
  345. if not(m_tp_procvar in aktmodeswitches) and
  346. (ppointerdef(def_to)^.definition^.deftype=orddef) and
  347. (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
  348. begin
  349. doconv:=tc_equal;
  350. b:=1;
  351. end;
  352. end;
  353. classrefdef,
  354. objectdef :
  355. begin
  356. { class types and class reference type
  357. can be assigned to void pointers }
  358. if (
  359. ((def_from^.deftype=objectdef) and pobjectdef(def_from)^.is_class) or
  360. (def_from^.deftype=classrefdef)
  361. ) and
  362. (ppointerdef(def_to)^.definition^.deftype=orddef) and
  363. (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
  364. begin
  365. doconv:=tc_equal;
  366. b:=1;
  367. end;
  368. end;
  369. end;
  370. end;
  371. setdef :
  372. begin
  373. { automatic arrayconstructor -> set conversion }
  374. if is_array_constructor(def_from) then
  375. begin
  376. doconv:=tc_arrayconstructor_2_set;
  377. b:=1;
  378. end;
  379. end;
  380. procvardef :
  381. begin
  382. { proc -> procvar }
  383. if (def_from^.deftype=procdef) then
  384. begin
  385. doconv:=tc_proc_2_procvar;
  386. if proc_to_procvar_equal(pprocdef(def_from),pprocvardef(def_to)) then
  387. b:=1;
  388. end
  389. else
  390. { for example delphi allows the assignement from pointers }
  391. { to procedure variables }
  392. if (m_pointer_2_procedure in aktmodeswitches) and
  393. (def_from^.deftype=pointerdef) and
  394. (ppointerdef(def_from)^.definition^.deftype=orddef) and
  395. (porddef(ppointerdef(def_from)^.definition)^.typ=uvoid) then
  396. begin
  397. doconv:=tc_equal;
  398. b:=1;
  399. end
  400. else
  401. { nil is compatible with procvars }
  402. if (fromtreetype=niln) then
  403. begin
  404. doconv:=tc_equal;
  405. b:=1;
  406. end;
  407. end;
  408. objectdef :
  409. begin
  410. { object pascal objects }
  411. if (def_from^.deftype=objectdef) {and
  412. pobjectdef(def_from)^.isclass and pobjectdef(def_to)^.isclass }then
  413. begin
  414. doconv:=tc_equal;
  415. if pobjectdef(def_from)^.is_related(pobjectdef(def_to)) then
  416. b:=1;
  417. end
  418. else
  419. { nil is compatible with class instances }
  420. if (fromtreetype=niln) and (pobjectdef(def_to)^.is_class) then
  421. begin
  422. doconv:=tc_equal;
  423. b:=1;
  424. end;
  425. end;
  426. classrefdef :
  427. begin
  428. { class reference types }
  429. if (def_from^.deftype=classrefdef) then
  430. begin
  431. doconv:=tc_equal;
  432. if pobjectdef(pclassrefdef(def_from)^.definition)^.is_related(
  433. pobjectdef(pclassrefdef(def_to)^.definition)) then
  434. b:=1;
  435. end
  436. else
  437. { nil is compatible with class references }
  438. if (fromtreetype=niln) then
  439. begin
  440. doconv:=tc_equal;
  441. b:=1;
  442. end;
  443. end;
  444. filedef :
  445. begin
  446. { typed files are all equal to the abstract file type
  447. name TYPEDFILE in system.pp in is_equal in types.pas
  448. the problem is that it sholud be also compatible to FILE
  449. but this would leed to a problem for ASSIGN RESET and REWRITE
  450. when trying to find the good overloaded function !!
  451. so all file function are doubled in system.pp
  452. this is not very beautiful !!}
  453. if (def_from^.deftype=filedef) and
  454. (
  455. (
  456. (pfiledef(def_from)^.filetype = ft_typed) and
  457. (pfiledef(def_to)^.filetype = ft_typed) and
  458. (
  459. (pfiledef(def_from)^.typed_as = pdef(voiddef)) or
  460. (pfiledef(def_to)^.typed_as = pdef(voiddef))
  461. )
  462. ) or
  463. (
  464. (
  465. (pfiledef(def_from)^.filetype = ft_untyped) and
  466. (pfiledef(def_to)^.filetype = ft_typed)
  467. ) or
  468. (
  469. (pfiledef(def_from)^.filetype = ft_typed) and
  470. (pfiledef(def_to)^.filetype = ft_untyped)
  471. )
  472. )
  473. ) then
  474. begin
  475. doconv:=tc_equal;
  476. b:=1;
  477. end
  478. end;
  479. else
  480. begin
  481. { assignment overwritten ?? }
  482. if assignment_overloaded(def_from,def_to)<>nil then
  483. b:=2;
  484. end;
  485. end;
  486. isconvertable:=b;
  487. end;
  488. {****************************************************************************
  489. Register Calculation
  490. ****************************************************************************}
  491. { marks an lvalue as "unregable" }
  492. procedure make_not_regable(p : ptree);
  493. begin
  494. case p^.treetype of
  495. typeconvn :
  496. make_not_regable(p^.left);
  497. loadn :
  498. if p^.symtableentry^.typ=varsym then
  499. pvarsym(p^.symtableentry)^.varoptions:=pvarsym(p^.symtableentry)^.varoptions-[vo_regable,vo_fpuregable];
  500. end;
  501. end;
  502. procedure left_right_max(p : ptree);
  503. begin
  504. if assigned(p^.left) then
  505. begin
  506. if assigned(p^.right) then
  507. begin
  508. p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
  509. p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
  510. {$ifdef SUPPORT_MMX}
  511. p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
  512. {$endif SUPPORT_MMX}
  513. end
  514. else
  515. begin
  516. p^.registers32:=p^.left^.registers32;
  517. p^.registersfpu:=p^.left^.registersfpu;
  518. {$ifdef SUPPORT_MMX}
  519. p^.registersmmx:=p^.left^.registersmmx;
  520. {$endif SUPPORT_MMX}
  521. end;
  522. end;
  523. end;
  524. { calculates the needed registers for a binary operator }
  525. procedure calcregisters(p : ptree;r32,fpu,mmx : word);
  526. begin
  527. left_right_max(p);
  528. { Only when the difference between the left and right registers < the
  529. wanted registers allocate the amount of registers }
  530. if assigned(p^.left) then
  531. begin
  532. if assigned(p^.right) then
  533. begin
  534. if (abs(p^.left^.registers32-p^.right^.registers32)<r32) then
  535. inc(p^.registers32,r32);
  536. if (abs(p^.left^.registersfpu-p^.right^.registersfpu)<fpu) then
  537. inc(p^.registersfpu,fpu);
  538. {$ifdef SUPPORT_MMX}
  539. if (abs(p^.left^.registersmmx-p^.right^.registersmmx)<mmx) then
  540. inc(p^.registersmmx,mmx);
  541. {$endif SUPPORT_MMX}
  542. end
  543. else
  544. begin
  545. if (p^.left^.registers32<r32) then
  546. inc(p^.registers32,r32);
  547. if (p^.left^.registersfpu<fpu) then
  548. inc(p^.registersfpu,fpu);
  549. {$ifdef SUPPORT_MMX}
  550. if (p^.left^.registersmmx<mmx) then
  551. inc(p^.registersmmx,mmx);
  552. {$endif SUPPORT_MMX}
  553. end;
  554. end;
  555. { error CGMessage, if more than 8 floating point }
  556. { registers are needed }
  557. if p^.registersfpu>8 then
  558. CGMessage(cg_e_too_complex_expr);
  559. end;
  560. {****************************************************************************
  561. Subroutine Handling
  562. ****************************************************************************}
  563. { protected field handling
  564. protected field can not appear in
  565. var parameters of function !!
  566. this can only be done after we have determined the
  567. overloaded function
  568. this is the reason why it is not in the parser, PM }
  569. procedure test_protected_sym(sym : psym);
  570. begin
  571. if (sp_protected in sym^.symoptions) and
  572. ((sym^.owner^.symtabletype=unitsymtable) or
  573. ((sym^.owner^.symtabletype=objectsymtable) and
  574. (pobjectdef(sym^.owner^.defowner)^.owner^.symtabletype=unitsymtable))
  575. ) then
  576. CGMessage(parser_e_cant_access_protected_member);
  577. end;
  578. procedure test_protected(p : ptree);
  579. begin
  580. case p^.treetype of
  581. loadn : test_protected_sym(p^.symtableentry);
  582. typeconvn : test_protected(p^.left);
  583. derefn : test_protected(p^.left);
  584. subscriptn : begin
  585. { test_protected(p^.left);
  586. Is a field of a protected var
  587. also protected ??? PM }
  588. test_protected_sym(p^.vs);
  589. end;
  590. end;
  591. end;
  592. function valid_for_formal_var(p : ptree) : boolean;
  593. var
  594. v : boolean;
  595. begin
  596. case p^.treetype of
  597. loadn : v:=(p^.symtableentry^.typ in [typedconstsym,varsym]);
  598. typeconvn : v:=valid_for_formal_var(p^.left);
  599. typen : v:=false;
  600. derefn,subscriptn,vecn,
  601. funcretn,selfn : v:=true;
  602. { procvars are callnodes first }
  603. calln : v:=assigned(p^.right) and not assigned(p^.left);
  604. { should this depend on mode ? }
  605. addrn : v:=true;
  606. { no other node accepted (PM) }
  607. else v:=false;
  608. end;
  609. valid_for_formal_var:=v;
  610. end;
  611. function valid_for_formal_const(p : ptree) : boolean;
  612. var
  613. v : boolean;
  614. begin
  615. { p must have been firstpass'd before }
  616. { accept about anything but not a statement ! }
  617. v:=true;
  618. if (p^.treetype in [calln,statementn]) then
  619. { if not assigned(p^.resulttype) or (p^.resulttype=pdef(voiddef)) then }
  620. v:=false;
  621. valid_for_formal_const:=v;
  622. end;
  623. function is_procsym_load(p:Ptree):boolean;
  624. begin
  625. is_procsym_load:=((p^.treetype=loadn) and (p^.symtableentry^.typ=procsym)) or
  626. ((p^.treetype=addrn) and (p^.left^.treetype=loadn)
  627. and (p^.left^.symtableentry^.typ=procsym)) ;
  628. end;
  629. { change a proc call to a procload for assignment to a procvar }
  630. { this can only happen for proc/function without arguments }
  631. function is_procsym_call(p:Ptree):boolean;
  632. begin
  633. is_procsym_call:=(p^.treetype=calln) and (p^.left=nil) and
  634. (((p^.symtableprocentry^.typ=procsym) and (p^.right=nil)) or
  635. ((p^.right<>nil) and (p^.right^.symtableprocentry^.typ=varsym)));
  636. end;
  637. function assignment_overloaded(from_def,to_def : pdef) : pprocdef;
  638. var
  639. passproc : pprocdef;
  640. convtyp : tconverttype;
  641. begin
  642. assignment_overloaded:=nil;
  643. if assigned(overloaded_operators[_assignment]) then
  644. passproc:=overloaded_operators[_assignment]^.definition
  645. else
  646. exit;
  647. while passproc<>nil do
  648. begin
  649. if is_equal(passproc^.retdef,to_def) and
  650. (is_equal(pparaitem(passproc^.para^.first)^.data,from_def) or
  651. (isconvertable(from_def,pparaitem(passproc^.para^.first)^.data,convtyp,ordconstn,false)=1)) then
  652. begin
  653. assignment_overloaded:=passproc;
  654. break;
  655. end;
  656. passproc:=passproc^.nextoverloaded;
  657. end;
  658. end;
  659. { local routines can't be assigned to procvars }
  660. procedure test_local_to_procvar(from_def:pprocvardef;to_def:pdef);
  661. begin
  662. if (from_def^.symtablelevel>1) and (to_def^.deftype=procvardef) then
  663. CGMessage(type_e_cannot_local_proc_to_procvar);
  664. end;
  665. function valid_for_assign(p:ptree;allowprop:boolean):boolean;
  666. var
  667. hp : ptree;
  668. gotderef : boolean;
  669. begin
  670. valid_for_assign:=false;
  671. gotderef:=false;
  672. hp:=p;
  673. while assigned(hp) do
  674. begin
  675. if (not allowprop) and
  676. (hp^.isproperty) then
  677. begin
  678. CGMessagePos(hp^.fileinfo,type_e_argument_cant_be_assigned);
  679. exit;
  680. end;
  681. case hp^.treetype of
  682. derefn :
  683. begin
  684. gotderef:=true;
  685. hp:=hp^.left;
  686. end;
  687. typeconvn,
  688. asn,
  689. vecn,
  690. subscriptn :
  691. hp:=hp^.left;
  692. subn,
  693. addn :
  694. begin
  695. { Allow add/sub operators on a pointer }
  696. if (hp^.resulttype^.deftype=pointerdef) then
  697. valid_for_assign:=true
  698. else
  699. CGMessagePos(hp^.fileinfo,type_e_variable_id_expected);
  700. exit;
  701. end;
  702. addrn :
  703. begin
  704. if not(gotderef) and
  705. not(hp^.procvarload) then
  706. CGMessagePos(hp^.fileinfo,type_e_no_assign_to_addr);
  707. exit;
  708. end;
  709. funcretn :
  710. begin
  711. valid_for_assign:=true;
  712. exit;
  713. end;
  714. calln :
  715. begin
  716. { only allow writing if it returns a pointer and we've
  717. found a deref }
  718. if (hp^.resulttype^.deftype=pointerdef) and
  719. gotderef then
  720. valid_for_assign:=true
  721. else
  722. CGMessagePos(hp^.fileinfo,type_e_argument_cant_be_assigned);
  723. exit;
  724. end;
  725. loadn :
  726. begin
  727. case hp^.symtableentry^.typ of
  728. absolutesym,
  729. varsym :
  730. begin
  731. if (pvarsym(hp^.symtableentry)^.varspez=vs_const) then
  732. begin
  733. CGMessagePos(hp^.fileinfo,type_e_no_assign_to_const);
  734. exit;
  735. end;
  736. { Are we at a with symtable, then we need to process the
  737. withrefnode also to check for maybe a const load }
  738. if (hp^.symtable^.symtabletype=withsymtable) then
  739. begin
  740. { continue with processing the withref node }
  741. hp:=ptree(pwithsymtable(hp^.symtable)^.withrefnode);
  742. end
  743. else
  744. begin
  745. { set the assigned flag for varsyms }
  746. if (pvarsym(hp^.symtableentry)^.varstate=vs_declared) then
  747. pvarsym(hp^.symtableentry)^.varstate:=vs_assigned;
  748. valid_for_assign:=true;
  749. exit;
  750. end;
  751. end;
  752. funcretsym,
  753. typedconstsym :
  754. begin
  755. valid_for_assign:=true;
  756. exit;
  757. end;
  758. end;
  759. end;
  760. else
  761. begin
  762. CGMessagePos(hp^.fileinfo,type_e_variable_id_expected);
  763. exit;
  764. end;
  765. end;
  766. end;
  767. end;
  768. end.
  769. {
  770. $Log$
  771. Revision 1.43 1999-10-27 16:04:45 peter
  772. * valid_for_assign support for calln,asn
  773. Revision 1.42 1999/10/26 12:30:41 peter
  774. * const parameter is now checked
  775. * better and generic check if a node can be used for assigning
  776. * export fixes
  777. * procvar equal works now (it never had worked at least from 0.99.8)
  778. * defcoll changed to linkedlist with pparaitem so it can easily be
  779. walked both directions
  780. Revision 1.41 1999/10/14 14:57:52 florian
  781. - removed the hcodegen use in the new cg, use cgbase instead
  782. Revision 1.40 1999/09/26 21:30:15 peter
  783. + constant pointer support which can happend with typecasting like
  784. const p=pointer(1)
  785. * better procvar parsing in typed consts
  786. Revision 1.39 1999/09/17 17:14:04 peter
  787. * @procvar fixes for tp mode
  788. * @<id>:= gives now an error
  789. Revision 1.38 1999/08/17 13:26:07 peter
  790. * arrayconstructor -> arrayofconst fixed when arraycosntructor was not
  791. variant.
  792. Revision 1.37 1999/08/16 23:23:38 peter
  793. * arrayconstructor -> openarray type conversions for element types
  794. Revision 1.36 1999/08/06 12:49:36 jonas
  795. * vo_fpuregable is now also removed in make_not_regable
  796. Revision 1.35 1999/08/05 21:50:35 peter
  797. * removed warning
  798. Revision 1.34 1999/08/05 16:52:55 peter
  799. * V_Fatal=1, all other V_ are also increased
  800. * Check for local procedure when assigning procvar
  801. * fixed comment parsing because directives
  802. * oldtp mode directives better supported
  803. * added some messages to errore.msg
  804. Revision 1.33 1999/08/04 13:02:43 jonas
  805. * all tokens now start with an underscore
  806. * PowerPC compiles!!
  807. Revision 1.32 1999/08/03 22:02:53 peter
  808. * moved bitmask constants to sets
  809. * some other type/const renamings
  810. Revision 1.31 1999/07/16 10:04:32 peter
  811. * merged
  812. Revision 1.30 1999/06/28 16:02:30 peter
  813. * merged
  814. Revision 1.27.2.4 1999/07/16 09:52:18 peter
  815. * allow char(enum)
  816. Revision 1.27.2.3 1999/06/28 15:51:27 peter
  817. * tp7 fix
  818. Revision 1.27.2.2 1999/06/18 10:56:58 daniel
  819. - Enumerations no longer compatible with integer types
  820. Revision 1.27.2.1 1999/06/17 12:51:42 pierre
  821. * changed is_assignment_overloaded into
  822. function assignment_overloaded : pprocdef
  823. to allow overloading of assignment with only different result type
  824. Revision 1.27 1999/06/01 19:27:47 peter
  825. * better checks for procvar and methodpointer
  826. Revision 1.26 1999/05/20 14:58:26 peter
  827. * fixed arrayconstruct->set conversion which didn't work for enum sets
  828. Revision 1.25 1999/05/19 20:40:12 florian
  829. * fixed a couple of array related bugs:
  830. - var a : array[0..1] of char; p : pchar; p:=a+123; works now
  831. - open arrays with an odd size doesn't work: movsb wasn't generated
  832. - introduced some new array type helper routines (is_special_array) etc.
  833. - made the array type checking in isconvertable more strict, often
  834. open array can be used where is wasn't allowed etc...
  835. Revision 1.24 1999/05/06 10:10:02 peter
  836. * overloaded conversion has lower priority
  837. Revision 1.23 1999/04/26 09:30:47 peter
  838. * small tp7 fix
  839. * fix void pointer with formaldef
  840. Revision 1.22 1999/04/21 22:00:01 pierre
  841. + valid_for_formal_var and valid_for_formal_const added
  842. Revision 1.21 1999/04/21 16:31:40 pierre
  843. ra386att.pas : problem with commit -m !
  844. Revision 1.20 1999/04/15 08:56:27 peter
  845. * fixed bool-bool conversion
  846. Revision 1.19 1999/03/24 23:17:02 peter
  847. * fixed bugs 212,222,225,227,229,231,233
  848. Revision 1.18 1999/03/06 17:25:19 peter
  849. * moved comp<->real warning so it doesn't occure everytime that
  850. isconvertable is called with
  851. Revision 1.17 1999/03/02 18:24:20 peter
  852. * fixed overloading of array of char
  853. Revision 1.16 1999/01/27 13:53:27 pierre
  854. htypechk.pas
  855. Revision 1.15 1999/01/27 13:12:10 pierre
  856. * bool to int must be explicit
  857. Revision 1.14 1999/01/19 15:55:32 pierre
  858. * fix for boolean to comp conversion (now disabled)
  859. Revision 1.13 1998/12/15 17:11:37 peter
  860. * string:=pchar not allowed in tp mode
  861. Revision 1.12 1998/12/11 00:03:18 peter
  862. + globtype,tokens,version unit splitted from globals
  863. Revision 1.11 1998/12/10 09:47:21 florian
  864. + basic operations with int64/qord (compiler with -dint64)
  865. + rtti of enumerations extended: names are now written
  866. Revision 1.10 1998/11/29 12:40:23 peter
  867. * newcnv -> not oldcnv
  868. Revision 1.9 1998/11/26 13:10:42 peter
  869. * new int - int conversion -dNEWCNV
  870. * some function renamings
  871. Revision 1.8 1998/11/17 00:36:42 peter
  872. * more ansistring fixes
  873. Revision 1.7 1998/10/14 13:33:24 peter
  874. * fixed small typo
  875. Revision 1.6 1998/10/14 12:53:38 peter
  876. * fixed small tp7 things
  877. * boolean:=longbool and longbool fixed
  878. Revision 1.5 1998/10/12 09:49:58 florian
  879. + support of <procedure var type>:=<pointer> in delphi mode added
  880. Revision 1.4 1998/09/30 16:42:52 peter
  881. * fixed bool-bool cnv
  882. Revision 1.3 1998/09/24 23:49:05 peter
  883. + aktmodeswitches
  884. Revision 1.2 1998/09/24 09:02:14 peter
  885. * rewritten isconvertable to use case
  886. * array of .. and single variable are compatible
  887. Revision 1.1 1998/09/23 20:42:22 peter
  888. * splitted pass_1
  889. }