htypechk.pas 34 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977
  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. vecn,
  689. subscriptn :
  690. hp:=hp^.left;
  691. subn,
  692. addn :
  693. begin
  694. { Allow add/sub operators on a pointer }
  695. if (hp^.resulttype^.deftype=pointerdef) then
  696. valid_for_assign:=true
  697. else
  698. CGMessagePos(hp^.fileinfo,type_e_variable_id_expected);
  699. exit;
  700. end;
  701. addrn :
  702. begin
  703. if not(gotderef) and
  704. not(hp^.procvarload) then
  705. CGMessagePos(hp^.fileinfo,type_e_no_assign_to_addr);
  706. exit;
  707. end;
  708. funcretn :
  709. begin
  710. valid_for_assign:=true;
  711. exit;
  712. end;
  713. loadn :
  714. begin
  715. case hp^.symtableentry^.typ of
  716. absolutesym,
  717. varsym :
  718. begin
  719. if (pvarsym(hp^.symtableentry)^.varspez=vs_const) then
  720. begin
  721. CGMessagePos(hp^.fileinfo,type_e_no_assign_to_const);
  722. exit;
  723. end;
  724. { Are we at a with symtable, then we need to process the
  725. withrefnode also to check for maybe a const load }
  726. if (hp^.symtable^.symtabletype=withsymtable) then
  727. begin
  728. { continue with processing the withref node }
  729. hp:=ptree(pwithsymtable(hp^.symtable)^.withrefnode);
  730. end
  731. else
  732. begin
  733. { set the assigned flag for varsyms }
  734. if (pvarsym(hp^.symtableentry)^.varstate=vs_declared) then
  735. pvarsym(hp^.symtableentry)^.varstate:=vs_assigned;
  736. valid_for_assign:=true;
  737. exit;
  738. end;
  739. end;
  740. funcretsym,
  741. typedconstsym :
  742. begin
  743. valid_for_assign:=true;
  744. exit;
  745. end;
  746. end;
  747. end;
  748. else
  749. begin
  750. CGMessagePos(hp^.fileinfo,type_e_variable_id_expected);
  751. exit;
  752. end;
  753. end;
  754. end;
  755. end;
  756. end.
  757. {
  758. $Log$
  759. Revision 1.42 1999-10-26 12:30:41 peter
  760. * const parameter is now checked
  761. * better and generic check if a node can be used for assigning
  762. * export fixes
  763. * procvar equal works now (it never had worked at least from 0.99.8)
  764. * defcoll changed to linkedlist with pparaitem so it can easily be
  765. walked both directions
  766. Revision 1.41 1999/10/14 14:57:52 florian
  767. - removed the hcodegen use in the new cg, use cgbase instead
  768. Revision 1.40 1999/09/26 21:30:15 peter
  769. + constant pointer support which can happend with typecasting like
  770. const p=pointer(1)
  771. * better procvar parsing in typed consts
  772. Revision 1.39 1999/09/17 17:14:04 peter
  773. * @procvar fixes for tp mode
  774. * @<id>:= gives now an error
  775. Revision 1.38 1999/08/17 13:26:07 peter
  776. * arrayconstructor -> arrayofconst fixed when arraycosntructor was not
  777. variant.
  778. Revision 1.37 1999/08/16 23:23:38 peter
  779. * arrayconstructor -> openarray type conversions for element types
  780. Revision 1.36 1999/08/06 12:49:36 jonas
  781. * vo_fpuregable is now also removed in make_not_regable
  782. Revision 1.35 1999/08/05 21:50:35 peter
  783. * removed warning
  784. Revision 1.34 1999/08/05 16:52:55 peter
  785. * V_Fatal=1, all other V_ are also increased
  786. * Check for local procedure when assigning procvar
  787. * fixed comment parsing because directives
  788. * oldtp mode directives better supported
  789. * added some messages to errore.msg
  790. Revision 1.33 1999/08/04 13:02:43 jonas
  791. * all tokens now start with an underscore
  792. * PowerPC compiles!!
  793. Revision 1.32 1999/08/03 22:02:53 peter
  794. * moved bitmask constants to sets
  795. * some other type/const renamings
  796. Revision 1.31 1999/07/16 10:04:32 peter
  797. * merged
  798. Revision 1.30 1999/06/28 16:02:30 peter
  799. * merged
  800. Revision 1.27.2.4 1999/07/16 09:52:18 peter
  801. * allow char(enum)
  802. Revision 1.27.2.3 1999/06/28 15:51:27 peter
  803. * tp7 fix
  804. Revision 1.27.2.2 1999/06/18 10:56:58 daniel
  805. - Enumerations no longer compatible with integer types
  806. Revision 1.27.2.1 1999/06/17 12:51:42 pierre
  807. * changed is_assignment_overloaded into
  808. function assignment_overloaded : pprocdef
  809. to allow overloading of assignment with only different result type
  810. Revision 1.27 1999/06/01 19:27:47 peter
  811. * better checks for procvar and methodpointer
  812. Revision 1.26 1999/05/20 14:58:26 peter
  813. * fixed arrayconstruct->set conversion which didn't work for enum sets
  814. Revision 1.25 1999/05/19 20:40:12 florian
  815. * fixed a couple of array related bugs:
  816. - var a : array[0..1] of char; p : pchar; p:=a+123; works now
  817. - open arrays with an odd size doesn't work: movsb wasn't generated
  818. - introduced some new array type helper routines (is_special_array) etc.
  819. - made the array type checking in isconvertable more strict, often
  820. open array can be used where is wasn't allowed etc...
  821. Revision 1.24 1999/05/06 10:10:02 peter
  822. * overloaded conversion has lower priority
  823. Revision 1.23 1999/04/26 09:30:47 peter
  824. * small tp7 fix
  825. * fix void pointer with formaldef
  826. Revision 1.22 1999/04/21 22:00:01 pierre
  827. + valid_for_formal_var and valid_for_formal_const added
  828. Revision 1.21 1999/04/21 16:31:40 pierre
  829. ra386att.pas : problem with commit -m !
  830. Revision 1.20 1999/04/15 08:56:27 peter
  831. * fixed bool-bool conversion
  832. Revision 1.19 1999/03/24 23:17:02 peter
  833. * fixed bugs 212,222,225,227,229,231,233
  834. Revision 1.18 1999/03/06 17:25:19 peter
  835. * moved comp<->real warning so it doesn't occure everytime that
  836. isconvertable is called with
  837. Revision 1.17 1999/03/02 18:24:20 peter
  838. * fixed overloading of array of char
  839. Revision 1.16 1999/01/27 13:53:27 pierre
  840. htypechk.pas
  841. Revision 1.15 1999/01/27 13:12:10 pierre
  842. * bool to int must be explicit
  843. Revision 1.14 1999/01/19 15:55:32 pierre
  844. * fix for boolean to comp conversion (now disabled)
  845. Revision 1.13 1998/12/15 17:11:37 peter
  846. * string:=pchar not allowed in tp mode
  847. Revision 1.12 1998/12/11 00:03:18 peter
  848. + globtype,tokens,version unit splitted from globals
  849. Revision 1.11 1998/12/10 09:47:21 florian
  850. + basic operations with int64/qord (compiler with -dint64)
  851. + rtti of enumerations extended: names are now written
  852. Revision 1.10 1998/11/29 12:40:23 peter
  853. * newcnv -> not oldcnv
  854. Revision 1.9 1998/11/26 13:10:42 peter
  855. * new int - int conversion -dNEWCNV
  856. * some function renamings
  857. Revision 1.8 1998/11/17 00:36:42 peter
  858. * more ansistring fixes
  859. Revision 1.7 1998/10/14 13:33:24 peter
  860. * fixed small typo
  861. Revision 1.6 1998/10/14 12:53:38 peter
  862. * fixed small tp7 things
  863. * boolean:=longbool and longbool fixed
  864. Revision 1.5 1998/10/12 09:49:58 florian
  865. + support of <procedure var type>:=<pointer> in delphi mode added
  866. Revision 1.4 1998/09/30 16:42:52 peter
  867. * fixed bool-bool cnv
  868. Revision 1.3 1998/09/24 23:49:05 peter
  869. + aktmodeswitches
  870. Revision 1.2 1998/09/24 09:02:14 peter
  871. * rewritten isconvertable to use case
  872. * array of .. and single variable are compatible
  873. Revision 1.1 1998/09/23 20:42:22 peter
  874. * splitted pass_1
  875. }