htypechk.pas 35 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003
  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.44 1999-11-04 23:11:21 peter
  780. * fixed pchar and deref detection for assigning
  781. Revision 1.43 1999/10/27 16:04:45 peter
  782. * valid_for_assign support for calln,asn
  783. Revision 1.42 1999/10/26 12:30:41 peter
  784. * const parameter is now checked
  785. * better and generic check if a node can be used for assigning
  786. * export fixes
  787. * procvar equal works now (it never had worked at least from 0.99.8)
  788. * defcoll changed to linkedlist with pparaitem so it can easily be
  789. walked both directions
  790. Revision 1.41 1999/10/14 14:57:52 florian
  791. - removed the hcodegen use in the new cg, use cgbase instead
  792. Revision 1.40 1999/09/26 21:30:15 peter
  793. + constant pointer support which can happend with typecasting like
  794. const p=pointer(1)
  795. * better procvar parsing in typed consts
  796. Revision 1.39 1999/09/17 17:14:04 peter
  797. * @procvar fixes for tp mode
  798. * @<id>:= gives now an error
  799. Revision 1.38 1999/08/17 13:26:07 peter
  800. * arrayconstructor -> arrayofconst fixed when arraycosntructor was not
  801. variant.
  802. Revision 1.37 1999/08/16 23:23:38 peter
  803. * arrayconstructor -> openarray type conversions for element types
  804. Revision 1.36 1999/08/06 12:49:36 jonas
  805. * vo_fpuregable is now also removed in make_not_regable
  806. Revision 1.35 1999/08/05 21:50:35 peter
  807. * removed warning
  808. Revision 1.34 1999/08/05 16:52:55 peter
  809. * V_Fatal=1, all other V_ are also increased
  810. * Check for local procedure when assigning procvar
  811. * fixed comment parsing because directives
  812. * oldtp mode directives better supported
  813. * added some messages to errore.msg
  814. Revision 1.33 1999/08/04 13:02:43 jonas
  815. * all tokens now start with an underscore
  816. * PowerPC compiles!!
  817. Revision 1.32 1999/08/03 22:02:53 peter
  818. * moved bitmask constants to sets
  819. * some other type/const renamings
  820. Revision 1.31 1999/07/16 10:04:32 peter
  821. * merged
  822. Revision 1.30 1999/06/28 16:02:30 peter
  823. * merged
  824. Revision 1.27.2.4 1999/07/16 09:52:18 peter
  825. * allow char(enum)
  826. Revision 1.27.2.3 1999/06/28 15:51:27 peter
  827. * tp7 fix
  828. Revision 1.27.2.2 1999/06/18 10:56:58 daniel
  829. - Enumerations no longer compatible with integer types
  830. Revision 1.27.2.1 1999/06/17 12:51:42 pierre
  831. * changed is_assignment_overloaded into
  832. function assignment_overloaded : pprocdef
  833. to allow overloading of assignment with only different result type
  834. Revision 1.27 1999/06/01 19:27:47 peter
  835. * better checks for procvar and methodpointer
  836. Revision 1.26 1999/05/20 14:58:26 peter
  837. * fixed arrayconstruct->set conversion which didn't work for enum sets
  838. Revision 1.25 1999/05/19 20:40:12 florian
  839. * fixed a couple of array related bugs:
  840. - var a : array[0..1] of char; p : pchar; p:=a+123; works now
  841. - open arrays with an odd size doesn't work: movsb wasn't generated
  842. - introduced some new array type helper routines (is_special_array) etc.
  843. - made the array type checking in isconvertable more strict, often
  844. open array can be used where is wasn't allowed etc...
  845. Revision 1.24 1999/05/06 10:10:02 peter
  846. * overloaded conversion has lower priority
  847. Revision 1.23 1999/04/26 09:30:47 peter
  848. * small tp7 fix
  849. * fix void pointer with formaldef
  850. Revision 1.22 1999/04/21 22:00:01 pierre
  851. + valid_for_formal_var and valid_for_formal_const added
  852. Revision 1.21 1999/04/21 16:31:40 pierre
  853. ra386att.pas : problem with commit -m !
  854. Revision 1.20 1999/04/15 08:56:27 peter
  855. * fixed bool-bool conversion
  856. Revision 1.19 1999/03/24 23:17:02 peter
  857. * fixed bugs 212,222,225,227,229,231,233
  858. Revision 1.18 1999/03/06 17:25:19 peter
  859. * moved comp<->real warning so it doesn't occure everytime that
  860. isconvertable is called with
  861. Revision 1.17 1999/03/02 18:24:20 peter
  862. * fixed overloading of array of char
  863. Revision 1.16 1999/01/27 13:53:27 pierre
  864. htypechk.pas
  865. Revision 1.15 1999/01/27 13:12:10 pierre
  866. * bool to int must be explicit
  867. Revision 1.14 1999/01/19 15:55:32 pierre
  868. * fix for boolean to comp conversion (now disabled)
  869. Revision 1.13 1998/12/15 17:11:37 peter
  870. * string:=pchar not allowed in tp mode
  871. Revision 1.12 1998/12/11 00:03:18 peter
  872. + globtype,tokens,version unit splitted from globals
  873. Revision 1.11 1998/12/10 09:47:21 florian
  874. + basic operations with int64/qord (compiler with -dint64)
  875. + rtti of enumerations extended: names are now written
  876. Revision 1.10 1998/11/29 12:40:23 peter
  877. * newcnv -> not oldcnv
  878. Revision 1.9 1998/11/26 13:10:42 peter
  879. * new int - int conversion -dNEWCNV
  880. * some function renamings
  881. Revision 1.8 1998/11/17 00:36:42 peter
  882. * more ansistring fixes
  883. Revision 1.7 1998/10/14 13:33:24 peter
  884. * fixed small typo
  885. Revision 1.6 1998/10/14 12:53:38 peter
  886. * fixed small tp7 things
  887. * boolean:=longbool and longbool fixed
  888. Revision 1.5 1998/10/12 09:49:58 florian
  889. + support of <procedure var type>:=<pointer> in delphi mode added
  890. Revision 1.4 1998/09/30 16:42:52 peter
  891. * fixed bool-bool cnv
  892. Revision 1.3 1998/09/24 23:49:05 peter
  893. + aktmodeswitches
  894. Revision 1.2 1998/09/24 09:02:14 peter
  895. * rewritten isconvertable to use case
  896. * array of .. and single variable are compatible
  897. Revision 1.1 1998/09/23 20:42:22 peter
  898. * splitted pass_1
  899. }