htypechk.pas 32 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917
  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,pass_1,
  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. begin
  689. { pchar -> array conversion is done then we need to see it
  690. as a deref, because a ^ is then not required anymore }
  691. if is_chararray(hp^.resulttype) and
  692. is_pchar(hp^.left^.resulttype) then
  693. gotderef:=true;
  694. hp:=hp^.left;
  695. end;
  696. vecn,
  697. asn,
  698. subscriptn :
  699. hp:=hp^.left;
  700. subn,
  701. addn :
  702. begin
  703. { Allow add/sub operators on a pointer }
  704. if (hp^.resulttype^.deftype=pointerdef) then
  705. valid_for_assign:=true
  706. else
  707. CGMessagePos(hp^.fileinfo,type_e_variable_id_expected);
  708. exit;
  709. end;
  710. addrn :
  711. begin
  712. if not(gotderef) and
  713. not(hp^.procvarload) then
  714. CGMessagePos(hp^.fileinfo,type_e_no_assign_to_addr);
  715. exit;
  716. end;
  717. funcretn :
  718. begin
  719. valid_for_assign:=true;
  720. exit;
  721. end;
  722. calln :
  723. begin
  724. { only allow writing if it returns a pointer and we've
  725. found a deref }
  726. if (hp^.resulttype^.deftype=pointerdef) and
  727. gotderef then
  728. valid_for_assign:=true
  729. else
  730. CGMessagePos(hp^.fileinfo,type_e_argument_cant_be_assigned);
  731. exit;
  732. end;
  733. loadn :
  734. begin
  735. case hp^.symtableentry^.typ of
  736. absolutesym,
  737. varsym :
  738. begin
  739. if (pvarsym(hp^.symtableentry)^.varspez=vs_const) then
  740. begin
  741. CGMessagePos(hp^.fileinfo,type_e_no_assign_to_const);
  742. exit;
  743. end;
  744. { Are we at a with symtable, then we need to process the
  745. withrefnode also to check for maybe a const load }
  746. if (hp^.symtable^.symtabletype=withsymtable) then
  747. begin
  748. { continue with processing the withref node }
  749. hp:=ptree(pwithsymtable(hp^.symtable)^.withrefnode);
  750. end
  751. else
  752. begin
  753. { set the assigned flag for varsyms }
  754. if (pvarsym(hp^.symtableentry)^.varstate=vs_declared) then
  755. pvarsym(hp^.symtableentry)^.varstate:=vs_assigned;
  756. valid_for_assign:=true;
  757. exit;
  758. end;
  759. end;
  760. funcretsym,
  761. typedconstsym :
  762. begin
  763. valid_for_assign:=true;
  764. exit;
  765. end;
  766. end;
  767. end;
  768. else
  769. begin
  770. CGMessagePos(hp^.fileinfo,type_e_variable_id_expected);
  771. exit;
  772. end;
  773. end;
  774. end;
  775. end;
  776. end.
  777. {
  778. $Log$
  779. Revision 1.45 1999-11-06 14:34:21 peter
  780. * truncated log to 20 revs
  781. Revision 1.44 1999/11/04 23:11:21 peter
  782. * fixed pchar and deref detection for assigning
  783. Revision 1.43 1999/10/27 16:04:45 peter
  784. * valid_for_assign support for calln,asn
  785. Revision 1.42 1999/10/26 12:30:41 peter
  786. * const parameter is now checked
  787. * better and generic check if a node can be used for assigning
  788. * export fixes
  789. * procvar equal works now (it never had worked at least from 0.99.8)
  790. * defcoll changed to linkedlist with pparaitem so it can easily be
  791. walked both directions
  792. Revision 1.41 1999/10/14 14:57:52 florian
  793. - removed the hcodegen use in the new cg, use cgbase instead
  794. Revision 1.40 1999/09/26 21:30:15 peter
  795. + constant pointer support which can happend with typecasting like
  796. const p=pointer(1)
  797. * better procvar parsing in typed consts
  798. Revision 1.39 1999/09/17 17:14:04 peter
  799. * @procvar fixes for tp mode
  800. * @<id>:= gives now an error
  801. Revision 1.38 1999/08/17 13:26:07 peter
  802. * arrayconstructor -> arrayofconst fixed when arraycosntructor was not
  803. variant.
  804. Revision 1.37 1999/08/16 23:23:38 peter
  805. * arrayconstructor -> openarray type conversions for element types
  806. Revision 1.36 1999/08/06 12:49:36 jonas
  807. * vo_fpuregable is now also removed in make_not_regable
  808. Revision 1.35 1999/08/05 21:50:35 peter
  809. * removed warning
  810. Revision 1.34 1999/08/05 16:52:55 peter
  811. * V_Fatal=1, all other V_ are also increased
  812. * Check for local procedure when assigning procvar
  813. * fixed comment parsing because directives
  814. * oldtp mode directives better supported
  815. * added some messages to errore.msg
  816. Revision 1.33 1999/08/04 13:02:43 jonas
  817. * all tokens now start with an underscore
  818. * PowerPC compiles!!
  819. Revision 1.32 1999/08/03 22:02:53 peter
  820. * moved bitmask constants to sets
  821. * some other type/const renamings
  822. Revision 1.31 1999/07/16 10:04:32 peter
  823. * merged
  824. Revision 1.30 1999/06/28 16:02:30 peter
  825. * merged
  826. Revision 1.27.2.4 1999/07/16 09:52:18 peter
  827. * allow char(enum)
  828. Revision 1.27.2.3 1999/06/28 15:51:27 peter
  829. * tp7 fix
  830. Revision 1.27.2.2 1999/06/18 10:56:58 daniel
  831. - Enumerations no longer compatible with integer types
  832. Revision 1.27.2.1 1999/06/17 12:51:42 pierre
  833. * changed is_assignment_overloaded into
  834. function assignment_overloaded : pprocdef
  835. to allow overloading of assignment with only different result type
  836. Revision 1.27 1999/06/01 19:27:47 peter
  837. * better checks for procvar and methodpointer
  838. }