3 Copyright (c) 1998-2000 by Florian Klaempfl
5 This unit exports some help routines for the type checking
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
21 ****************************************************************************
33 op_overloading_supported
: boolean;
38 tok2node
:array[1..tok2nodes
] of ttok2noderec
=(
39 (tok
:_PLUS
;nod
:addn
;op_overloading_supported
:true), { binary overloading supported }
40 (tok
:_MINUS
;nod
:subn
;op_overloading_supported
:true), { binary and unary overloading supported }
41 (tok
:_STAR
;nod
:muln
;op_overloading_supported
:true), { binary overloading supported }
42 (tok
:_SLASH
;nod
:slashn
;op_overloading_supported
:true), { binary overloading supported }
43 (tok
:_EQUAL
;nod
:equaln
;op_overloading_supported
:true), { binary overloading supported }
44 (tok
:_GT
;nod
:gtn
;op_overloading_supported
:true), { binary overloading supported }
45 (tok
:_LT
;nod
:ltn
;op_overloading_supported
:true), { binary overloading supported }
46 (tok
:_GTE
;nod
:gten
;op_overloading_supported
:true), { binary overloading supported }
47 (tok
:_LTE
;nod
:lten
;op_overloading_supported
:true), { binary overloading supported }
48 (tok
:_SYMDIF
;nod
:symdifn
;op_overloading_supported
:true), { binary overloading supported }
49 (tok
:_STARSTAR
;nod
:starstarn
;op_overloading_supported
:true), { binary overloading supported }
50 (tok
:_OP_AS
;nod
:asn
;op_overloading_supported
:false), { binary overloading NOT supported }
51 (tok
:_OP_IN
;nod
:inn
;op_overloading_supported
:false), { binary overloading NOT supported }
52 (tok
:_OP_IS
;nod
:isn
;op_overloading_supported
:false), { binary overloading NOT supported }
53 (tok
:_OP_OR
;nod
:orn
;op_overloading_supported
:true), { binary overloading supported }
54 (tok
:_OP_AND
;nod
:andn
;op_overloading_supported
:true), { binary overloading supported }
55 (tok
:_OP_DIV
;nod
:divn
;op_overloading_supported
:true), { binary overloading supported }
56 (tok
:_OP_NOT
;nod
:notn
;op_overloading_supported
:true), { unary overloading supported }
57 (tok
:_OP_MOD
;nod
:modn
;op_overloading_supported
:true), { binary overloading supported }
58 (tok
:_OP_SHL
;nod
:shln
;op_overloading_supported
:true), { binary overloading supported }
59 (tok
:_OP_SHR
;nod
:shrn
;op_overloading_supported
:true), { binary overloading supported }
60 (tok
:_OP_XOR
;nod
:xorn
;op_overloading_supported
:true), { binary overloading supported }
61 (tok
:_ASSIGNMENT
;nod
:assignn
;op_overloading_supported
:true), { unary overloading supported }
62 (tok
:_CARET
;nod
:caretn
;op_overloading_supported
:false), { binary overloading NOT supported }
63 (tok
:_UNEQUAL
;nod
:unequaln
;op_overloading_supported
:false) { binary overloading NOT supported overload = instead }
66 { firstcallparan without varspez we don't count the ref }
68 count_ref
: boolean = true;
70 get_para_resulttype
: boolean = false;
71 allow_array_constructor
: boolean = false;
75 function isconvertable(def_from
,def_to
: pdef
;
76 var doconv
: tconverttype
;fromtreetype
: ttreetyp
;
77 explicit
: boolean) : byte;
78 { is overloading of this operator allowed for this
80 function isbinaryoperatoroverloadable(ld
, rd
,dd
: pdef
;
81 treetyp
: ttreetyp
) : boolean;
83 { is overloading of this operator allowed for this
85 function isunaryoperatoroverloadable(rd
,dd
: pdef
;
86 treetyp
: ttreetyp
) : boolean;
88 { check operator args and result type }
89 function isoperatoracceptable(pf
: pprocdef
; optoken
: ttoken
) : boolean;
91 { Register Allocation }
92 procedure make_not_regable(p
: ptree
);
93 procedure left_right_max(p
: ptree
);
94 procedure calcregisters(p
: ptree
;r32
,fpu
,mmx
: word);
96 { subroutine handling }
97 procedure test_protected_sym(sym
: psym
);
98 procedure test_protected(p
: ptree
);
99 function valid_for_formal_var(p
: ptree
) : boolean;
100 function valid_for_formal_const(p
: ptree
) : boolean;
101 function is_procsym_load(p
:Ptree
):boolean;
102 function is_procsym_call(p
:Ptree
):boolean;
103 function assignment_overloaded(from_def
,to_def
: pdef
) : pprocdef
;
104 procedure test_local_to_procvar(from_def
:pprocvardef
;to_def
:pdef
);
105 function valid_for_assign(p
:ptree
;allowprop
:boolean):boolean;
112 cobjects
,verbose
,globals
,
114 types
,pass_1
,cpubase
,
122 {****************************************************************************
124 ****************************************************************************}
129 2 - Convertable, but not first choice }
130 function isconvertable(def_from
,def_to
: pdef
;
131 var doconv
: tconverttype
;fromtreetype
: ttreetyp
;
132 explicit
: boolean) : byte;
134 { Tbasetype: uauto,uvoid,uchar,
137 bool8bit,bool16bit,bool32bit,
140 tbasedef
=(bvoid
,bchar
,bint
,bbool
);
142 basedeftbl
:array[tbasetype
] of tbasedef
=
146 bbool
,bbool
,bbool
,bint
,bint
,bchar
);
148 basedefconverts
: array[tbasedef
,tbasedef
] of tconverttype
=
149 ((tc_not_possible
,tc_not_possible
,tc_not_possible
,tc_not_possible
),
150 (tc_not_possible
,tc_equal
,tc_not_possible
,tc_not_possible
),
151 (tc_not_possible
,tc_not_possible
,tc_int_2_int
,tc_int_2_bool
),
152 (tc_not_possible
,tc_not_possible
,tc_bool_2_int
,tc_bool_2_bool
));
160 if not(assigned(def_from
) and assigned(def_to
)) then
166 { tp7 procvar def support, in tp7 a procvar is always called, if the
167 procvar is passed explicit a addrn would be there }
168 if (m_tp_procvar
in aktmodeswitches
) and
169 (def_from
^.deftype
=procvardef
) and
170 (fromtreetype
=loadn
) then
172 def_from
:=pprocvardef(def_from
)^.rettype
.def
;
175 { we walk the wanted (def_to) types and check then the def_from
176 types if there is a conversion possible }
178 case def_to
^.deftype
of
181 case def_from
^.deftype
of
184 doconv
:=basedefconverts
[basedeftbl
[porddef(def_from
)^.typ
],basedeftbl
[porddef(def_to
)^.typ
]];
186 if (doconv
=tc_not_possible
) or
187 ((doconv
=tc_int_2_bool
) and
189 (not is_boolean(def_from
))) or
190 ((doconv
=tc_bool_2_int
) and
192 (not is_boolean(def_to
))) then
197 { needed for char(enum) }
200 doconv
:=tc_int_2_int
;
209 case def_from
^.deftype
of
212 doconv
:=tc_string_2_string
;
218 if is_char(def_from
) then
220 doconv
:=tc_char_2_string
;
226 { array of char to string, the length check is done by the firstpass of this node }
227 if is_chararray(def_from
) then
229 doconv
:=tc_chararray_2_string
;
230 if (is_shortstring(def_to
) and
231 (def_from
^.size
<= 255)) or
232 (is_ansistring(def_to
) and
233 (def_from
^.size
> 255)) then
241 { pchar can be assigned to short/ansistrings,
242 but not in tp7 compatible mode }
243 if is_pchar(def_from
) and not(m_tp7
in aktmodeswitches
) then
245 doconv
:=tc_pchar_2_string
;
246 { prefer ansistrings because pchars can overflow shortstrings, }
247 { but only if ansistrings are the default (JM) }
248 if (is_shortstring(def_to
) and
249 not(cs_ansistrings
in aktlocalswitches
)) or
250 (is_ansistring(def_to
) and
251 (cs_ansistrings
in aktlocalswitches
)) then
262 case def_from
^.deftype
of
264 begin { ordinal to real }
265 if is_integer(def_from
) then
267 if pfloatdef(def_to
)^.typ
=f32bit
then
270 doconv
:=tc_int_2_real
;
275 begin { 2 float types ? }
276 if pfloatdef(def_from
)^.typ
=pfloatdef(def_to
)^.typ
then
280 if pfloatdef(def_from
)^.typ
=f32bit
then
281 doconv
:=tc_fix_2_real
283 if pfloatdef(def_to
)^.typ
=f32bit
then
284 doconv
:=tc_real_2_fix
286 doconv
:=tc_real_2_real
;
295 if (def_from
^.deftype
=enumdef
) then
298 while assigned(penumdef(hd1
)^.basedef
) do
299 hd1
:=penumdef(hd1
)^.basedef
;
301 while assigned(penumdef(hd2
)^.basedef
) do
302 hd2
:=penumdef(hd2
)^.basedef
;
306 { because of packenum they can have different sizes! (JM) }
307 doconv
:=tc_int_2_int
;
314 { open array is also compatible with a single element of its base type }
315 if is_open_array(def_to
) and
316 is_equal(parraydef(def_to
)^.elementtype
.def
,def_from
) then
323 case def_from
^.deftype
of
326 { array constructor -> open array }
327 if is_open_array(def_to
) and
328 is_array_constructor(def_from
) then
330 if is_void(parraydef(def_from
)^.elementtype
.def
) or
331 is_equal(parraydef(def_to
)^.elementtype
.def
,parraydef(def_from
)^.elementtype
.def
) then
337 if isconvertable(parraydef(def_from
)^.elementtype
.def
,
338 parraydef(def_to
)^.elementtype
.def
,hct
,arrayconstructn
,false)<>0 then
347 if is_zero_based_array(def_to
) and
348 is_equal(ppointerdef(def_from
)^.pointertype
.def
,parraydef(def_to
)^.elementtype
.def
) then
350 doconv
:=tc_pointer_2_array
;
356 { string to array of char}
357 if (not(is_special_array(def_to
)) or is_open_array(def_to
)) and
358 is_equal(parraydef(def_to
)^.elementtype
.def
,cchardef
) then
360 doconv
:=tc_string_2_chararray
;
370 case def_from
^.deftype
of
373 { string constant (which can be part of array constructor)
374 to zero terminated string constant }
375 if (fromtreetype
in [arrayconstructn
,stringconstn
]) and
376 is_pchar(def_to
) then
378 doconv
:=tc_cstring_2_pchar
;
384 { char constant to zero terminated string constant }
385 if (fromtreetype
=ordconstn
) then
387 if is_equal(def_from
,cchardef
) and
388 is_pchar(def_to
) then
390 doconv
:=tc_cchar_2_pchar
;
394 if is_integer(def_from
) then
396 doconv
:=tc_cord_2_pointer
;
403 { chararray to pointer }
404 if is_zero_based_array(def_from
) and
405 is_equal(parraydef(def_from
)^.elementtype
.def
,ppointerdef(def_to
)^.pointertype
.def
) then
407 doconv
:=tc_array_2_pointer
;
413 { child class pointer can be assigned to anchestor pointers }
415 (ppointerdef(def_from
)^.pointertype
.def
^.deftype
=objectdef
) and
416 (ppointerdef(def_to
)^.pointertype
.def
^.deftype
=objectdef
) and
417 pobjectdef(ppointerdef(def_from
)^.pointertype
.def
)^.is_related(
418 pobjectdef(ppointerdef(def_to
)^.pointertype
.def
))
420 { all pointers can be assigned to void-pointer }
421 is_equal(ppointerdef(def_to
)^.pointertype
.def
,voiddef
) or
422 { in my opnion, is this not clean pascal }
423 { well, but it's handy to use, it isn't ? (FK) }
424 is_equal(ppointerdef(def_from
)^.pointertype
.def
,voiddef
) then
432 { procedure variable can be assigned to an void pointer }
433 { Not anymore. Use the @ operator now.}
434 if not(m_tp_procvar
in aktmodeswitches
) and
435 (ppointerdef(def_to
)^.pointertype
.def
^.deftype
=orddef
) and
436 (porddef(ppointerdef(def_to
)^.pointertype
.def
)^.typ
=uvoid
) then
445 { class types and class reference type
446 can be assigned to void pointers }
448 ((def_from
^.deftype
=objectdef
) and pobjectdef(def_from
)^.is_class
) or
449 (def_from
^.deftype
=classrefdef
)
451 (ppointerdef(def_to
)^.pointertype
.def
^.deftype
=orddef
) and
452 (porddef(ppointerdef(def_to
)^.pointertype
.def
)^.typ
=uvoid
) then
463 { automatic arrayconstructor -> set conversion }
464 if is_array_constructor(def_from
) then
466 doconv
:=tc_arrayconstructor_2_set
;
474 if (def_from
^.deftype
=procdef
) then
476 doconv
:=tc_proc_2_procvar
;
477 if proc_to_procvar_equal(pprocdef(def_from
),pprocvardef(def_to
)) then
481 { for example delphi allows the assignement from pointers }
482 { to procedure variables }
483 if (m_pointer_2_procedure
in aktmodeswitches
) and
484 (def_from
^.deftype
=pointerdef
) and
485 (ppointerdef(def_from
)^.pointertype
.def
^.deftype
=orddef
) and
486 (porddef(ppointerdef(def_from
)^.pointertype
.def
)^.typ
=uvoid
) then
492 { nil is compatible with procvars }
493 if (fromtreetype
=niln
) then
502 { object pascal objects }
503 if (def_from
^.deftype
=objectdef
) {and
504 pobjectdef(def_from)^.isclass and pobjectdef(def_to)^.isclass }then
507 if pobjectdef(def_from
)^.is_related(pobjectdef(def_to
)) then
512 if (pobjectdef(def_to
)^.is_class
) then
514 { void pointer also for delphi mode }
515 if (m_delphi
in aktmodeswitches
) and
516 is_voidpointer(def_from
) then
522 { nil is compatible with class instances }
523 if (fromtreetype
=niln
) and (pobjectdef(def_to
)^.is_class
) then
533 { class reference types }
534 if (def_from
^.deftype
=classrefdef
) then
537 if pobjectdef(pclassrefdef(def_from
)^.pointertype
.def
)^.is_related(
538 pobjectdef(pclassrefdef(def_to
)^.pointertype
.def
)) then
542 { nil is compatible with class references }
543 if (fromtreetype
=niln
) then
552 { typed files are all equal to the abstract file type
553 name TYPEDFILE in system.pp in is_equal in types.pas
554 the problem is that it sholud be also compatible to FILE
555 but this would leed to a problem for ASSIGN RESET and REWRITE
556 when trying to find the good overloaded function !!
557 so all file function are doubled in system.pp
558 this is not very beautiful !!}
559 if (def_from
^.deftype
=filedef
) and
562 (pfiledef(def_from
)^.filetyp
= ft_typed
) and
563 (pfiledef(def_to
)^.filetyp
= ft_typed
) and
565 (pfiledef(def_from
)^.typedfiletype
.def
= pdef(voiddef
)) or
566 (pfiledef(def_to
)^.typedfiletype
.def
= pdef(voiddef
))
571 (pfiledef(def_from
)^.filetyp
= ft_untyped
) and
572 (pfiledef(def_to
)^.filetyp
= ft_typed
)
575 (pfiledef(def_from
)^.filetyp
= ft_typed
) and
576 (pfiledef(def_to
)^.filetyp
= ft_untyped
)
588 { assignment overwritten ?? }
589 if assignment_overloaded(def_from
,def_to
)<>nil then
596 { ld is the left type definition
597 rd the right type definition
598 dd the result type definition or voiddef if unkown }
599 function isbinaryoperatoroverloadable(ld
, rd
, dd
: pdef
;
600 treetyp
: ttreetyp
) : boolean;
602 isbinaryoperatoroverloadable
:=
603 (treetyp
=starstarn
) or
604 (ld
^.deftype
=recorddef
) or
605 (rd
^.deftype
=recorddef
) or
606 ((rd
^.deftype
=pointerdef
) and
609 (ld
^.deftype
=stringdef
) or
611 (not(ld
^.deftype
in [pointerdef
,objectdef
,classrefdef
,procvardef
]) or
612 not (treetyp
in [equaln
,unequaln
,gtn
,gten
,ltn
,lten
,subn
])
614 (not is_integer(ld
) or not (treetyp
in [addn
,subn
]))
616 ((ld
^.deftype
=pointerdef
) and
619 (rd
^.deftype
=stringdef
) or
621 (not(rd
^.deftype
in [stringdef
,pointerdef
,objectdef
,classrefdef
,procvardef
]) and
622 ((not is_integer(rd
) and (rd
^.deftype
<>objectdef
)
623 and (rd
^.deftype
<>classrefdef
)) or
624 not (treetyp
in [equaln
,unequaln
,gtn
,gten
,ltn
,lten
,addn
,subn
])
628 { array def, but not mmx or chararray+[char,string,chararray] }
629 ((ld
^.deftype
=arraydef
) and
630 not((cs_mmx
in aktlocalswitches
) and
631 is_mmx_able_array(ld
)) and
632 not(is_chararray(ld
) and
635 (rd
^.deftype
=stringdef
) or
638 ((rd
^.deftype
=arraydef
) and
639 not((cs_mmx
in aktlocalswitches
) and
640 is_mmx_able_array(rd
)) and
641 not(is_chararray(rd
) and
644 (ld
^.deftype
=stringdef
) or
647 { <> and = are defined for classes }
648 ((ld
^.deftype
=objectdef
) and
649 (not(pobjectdef(ld
)^.is_class
) or
650 not(treetyp
in [equaln
,unequaln
])
653 ((rd
^.deftype
=objectdef
) and
654 (not(pobjectdef(rd
)^.is_class
) or
655 not(treetyp
in [equaln
,unequaln
])
658 { allow other operators that + on strings }
662 (rd
^.deftype
=stringdef
) or
666 (ld
^.deftype
=stringdef
) or
669 not(treetyp
in [addn
,equaln
,unequaln
,gtn
,gten
,ltn
,lten
]) and
671 (is_integer(rd
) or (rd
^.deftype
=pointerdef
)) and
679 function isunaryoperatoroverloadable(rd
,dd
: pdef
;
680 treetyp
: ttreetyp
) : boolean;
682 isunaryoperatoroverloadable
:=false;
683 { what assignment overloading should be allowed ?? }
684 if (treetyp
=assignn
) then
686 isunaryoperatoroverloadable
:=true;
687 { this already get tbs0261 to fail
688 isunaryoperatoroverloadable:=not is_equal(rd,dd); PM }
690 { should we force that rd and dd are equal ?? }
691 else if (treetyp
=subn
{ unaryminusn }) then
693 isunaryoperatoroverloadable
:=
694 not is_integer(rd
) and not (rd
^.deftype
=floatdef
)
696 and not ((cs_mmx
in aktlocalswitches
) and
697 is_mmx_able_array(rd
))
701 else if (treetyp
=notn
) then
703 isunaryoperatoroverloadable
:=not is_integer(rd
) and not is_boolean(rd
)
705 and not ((cs_mmx
in aktlocalswitches
) and
706 is_mmx_able_array(rd
))
712 function isoperatoracceptable(pf
: pprocdef
; optoken
: ttoken
) : boolean;
717 case pf
^.parast
^.symindex
^.count
of
719 isoperatoracceptable
:=false;
720 for i
:=1 to tok2nodes
do
721 if tok2node
[i
].tok
=optoken
then
723 ld
:=pvarsym(pf
^.parast
^.symindex
^.first
)^.vartype
.def
;
724 rd
:=pvarsym(pf
^.parast
^.symindex
^.first
^.indexnext
)^.vartype
.def
;
726 isoperatoracceptable
:=
727 tok2node
[i
].op_overloading_supported
and
728 isbinaryoperatoroverloadable(ld
,rd
,dd
,tok2node
[i
].nod
);
733 rd
:=pvarsym(pf
^.parast
^.symindex
^.first
)^.vartype
.def
;
735 for i
:=1 to tok2nodes
do
736 if tok2node
[i
].tok
=optoken
then
738 isoperatoracceptable
:=
739 tok2node
[i
].op_overloading_supported
and
740 isunaryoperatoroverloadable(rd
,dd
,tok2node
[i
].nod
);
745 isoperatoracceptable
:=false;
749 {****************************************************************************
751 ****************************************************************************}
753 { marks an lvalue as "unregable" }
754 procedure make_not_regable(p
: ptree
);
758 make_not_regable(p
^.left
);
760 if p
^.symtableentry
^.typ
=varsym
then
761 pvarsym(p
^.symtableentry
)^.varoptions
:=pvarsym(p
^.symtableentry
)^.varoptions
-[vo_regable
,vo_fpuregable
];
766 procedure left_right_max(p
: ptree
);
768 if assigned(p
^.left
) then
770 if assigned(p
^.right
) then
772 p
^.registers32
:=max(p
^.left
^.registers32
,p
^.right
^.registers32
);
773 p
^.registersfpu
:=max(p
^.left
^.registersfpu
,p
^.right
^.registersfpu
);
775 p
^.registersmmx
:=max(p
^.left
^.registersmmx
,p
^.right
^.registersmmx
);
780 p
^.registers32
:=p
^.left
^.registers32
;
781 p
^.registersfpu
:=p
^.left
^.registersfpu
;
783 p
^.registersmmx
:=p
^.left
^.registersmmx
;
789 { calculates the needed registers for a binary operator }
790 procedure calcregisters(p
: ptree
;r32
,fpu
,mmx
: word);
795 { Only when the difference between the left and right registers < the
796 wanted registers allocate the amount of registers }
798 if assigned(p
^.left
) then
800 if assigned(p
^.right
) then
802 if (abs(p
^.left
^.registers32
-p
^.right
^.registers32
)<r32
) then
803 inc(p
^.registers32
,r32
);
804 if (abs(p
^.left
^.registersfpu
-p
^.right
^.registersfpu
)<fpu
) then
805 inc(p
^.registersfpu
,fpu
);
807 if (abs(p
^.left
^.registersmmx
-p
^.right
^.registersmmx
)<mmx
) then
808 inc(p
^.registersmmx
,mmx
);
810 { the following is a little bit guessing but I think }
811 { it's the only way to solve same internalerrors: }
812 { if the left and right node both uses registers }
813 { and return a mem location, but the current node }
814 { doesn't use an integer register we get probably }
815 { trouble when restoring a node }
816 if (p
^.left
^.registers32
=p
^.right
^.registers32
) and
817 (p
^.registers32
=p
^.left
^.registers32
) and
818 (p
^.registers32
>0) and
819 (p
^.left
^.location
.loc
in [LOC_REFERENCE
,LOC_MEM
]) and
820 (p
^.right
^.location
.loc
in [LOC_REFERENCE
,LOC_MEM
]) then
825 if (p
^.left
^.registers32
<r32
) then
826 inc(p
^.registers32
,r32
);
827 if (p
^.left
^.registersfpu
<fpu
) then
828 inc(p
^.registersfpu
,fpu
);
830 if (p
^.left
^.registersmmx
<mmx
) then
831 inc(p
^.registersmmx
,mmx
);
836 { error CGMessage, if more than 8 floating point }
837 { registers are needed }
838 if p
^.registersfpu
>8 then
839 CGMessage(cg_e_too_complex_expr
);
842 {****************************************************************************
844 ****************************************************************************}
846 { protected field handling
847 protected field can not appear in
848 var parameters of function !!
849 this can only be done after we have determined the
851 this is the reason why it is not in the parser, PM }
853 procedure test_protected_sym(sym
: psym
);
855 if (sp_protected
in sym
^.symoptions
) and
856 ((sym
^.owner
^.symtabletype
=unitsymtable
) or
857 ((sym
^.owner
^.symtabletype
=objectsymtable
) and
858 (pobjectdef(sym
^.owner
^.defowner
)^.owner
^.symtabletype
=unitsymtable
))
860 CGMessage(parser_e_cant_access_protected_member
);
864 procedure test_protected(p
: ptree
);
867 loadn
: test_protected_sym(p
^.symtableentry
);
868 typeconvn
: test_protected(p
^.left
);
869 derefn
: test_protected(p
^.left
);
871 { test_protected(p^.left);
872 Is a field of a protected var
873 also protected ??? PM }
874 test_protected_sym(p
^.vs
);
879 function valid_for_formal_var(p
: ptree
) : boolean;
885 v
:=(p
^.symtableentry
^.typ
in [typedconstsym
,varsym
]);
887 v
:=valid_for_formal_var(p
^.left
);
894 calln
: { procvars are callnodes first }
895 v
:=assigned(p
^.right
) and not assigned(p
^.left
);
898 { addrn is not allowed as this generate a constant value,
899 but a tp procvar are allowed (PFV) }
900 if p
^.procvarload
then
908 valid_for_formal_var
:=v
;
911 function valid_for_formal_const(p
: ptree
) : boolean;
915 { p must have been firstpass'd before }
916 { accept about anything but not a statement ! }
922 { addrn is not allowed as this generate a constant value,
923 but a tp procvar are allowed (PFV) }
924 if p
^.procvarload
then
932 valid_for_formal_const
:=v
;
935 function is_procsym_load(p
:Ptree
):boolean;
937 is_procsym_load
:=((p
^.treetype
=loadn
) and (p
^.symtableentry
^.typ
=procsym
)) or
938 ((p
^.treetype
=addrn
) and (p
^.left
^.treetype
=loadn
)
939 and (p
^.left
^.symtableentry
^.typ
=procsym
)) ;
942 { change a proc call to a procload for assignment to a procvar }
943 { this can only happen for proc/function without arguments }
944 function is_procsym_call(p
:Ptree
):boolean;
946 is_procsym_call
:=(p
^.treetype
=calln
) and (p
^.left
=nil) and
947 (((p
^.symtableprocentry
^.typ
=procsym
) and (p
^.right
=nil)) or
948 ((p
^.right
<>nil) and (p
^.right
^.symtableprocentry
^.typ
=varsym
)));
952 function assignment_overloaded(from_def
,to_def
: pdef
) : pprocdef
;
955 convtyp
: tconverttype
;
957 assignment_overloaded
:=nil;
958 if assigned(overloaded_operators
[_assignment
]) then
959 passproc
:=overloaded_operators
[_assignment
]^.definition
962 while passproc
<>nil do
964 if is_equal(passproc
^.rettype
.def
,to_def
) and
965 (is_equal(pparaitem(passproc
^.para
^.first
)^.paratype
.def
,from_def
) or
966 (isconvertable(from_def
,pparaitem(passproc
^.para
^.first
)^.paratype
.def
,convtyp
,ordconstn
,false)=1)) then
968 assignment_overloaded
:=passproc
;
971 passproc
:=passproc
^.nextoverloaded
;
976 { local routines can't be assigned to procvars }
977 procedure test_local_to_procvar(from_def
:pprocvardef
;to_def
:pdef
);
979 if (from_def
^.symtablelevel
>1) and (to_def
^.deftype
=procvardef
) then
980 CGMessage(type_e_cannot_local_proc_to_procvar
);
984 function valid_for_assign(p
:ptree
;allowprop
:boolean):boolean;
993 valid_for_assign
:=false;
1000 while assigned(hp
) do
1002 { property allowed? calln has a property check itself }
1003 if (not allowprop
) and
1004 (hp
^.isproperty
) and
1005 (hp
^.treetype
<>calln
) then
1007 CGMessagePos(hp
^.fileinfo
,type_e_argument_cant_be_assigned
);
1010 case hp
^.treetype
of
1018 case hp
^.resulttype
^.deftype
of
1022 gotclass
:=pobjectdef(hp
^.resulttype
)^.is_class
;
1027 { pointer -> array conversion is done then we need to see it
1028 as a deref, because a ^ is then not required anymore }
1029 if (hp
^.left
^.resulttype
^.deftype
=pointerdef
) then
1042 { a class/interface access is an implicit }
1044 if (hp
^.resulttype
^.deftype
=objectdef
) and
1045 pobjectdef(hp
^.resulttype
)^.is_class
then
1051 { Allow add/sub operators on a pointer, or an integer
1052 and a pointer typecast and deref has been found }
1053 if (hp
^.resulttype
^.deftype
=pointerdef
) or
1054 (is_integer(hp
^.resulttype
) and gotpointer
and gotderef
) then
1055 valid_for_assign
:=true
1057 CGMessagePos(hp
^.fileinfo
,type_e_variable_id_expected
);
1062 if not(gotderef
) and
1063 not(hp
^.procvarload
) then
1064 CGMessagePos(hp
^.fileinfo
,type_e_no_assign_to_addr
);
1070 valid_for_assign
:=true;
1075 { check return type }
1076 case hp
^.resulttype
^.deftype
of
1080 gotclass
:=pobjectdef(hp
^.resulttype
)^.is_class
;
1081 recorddef
, { handle record like class it needs a subscription }
1085 { 1. if it returns a pointer and we've found a deref,
1086 2. if it returns a class or record and a subscription or with is found,
1087 3. property is allowed }
1088 if (gotpointer
and gotderef
) or
1089 (gotclass
and (gotsubscript
or gotwith
)) or
1090 (hp
^.isproperty
and allowprop
) then
1091 valid_for_assign
:=true
1093 CGMessagePos(hp
^.fileinfo
,type_e_argument_cant_be_assigned
);
1098 case hp
^.symtableentry
^.typ
of
1102 if (pvarsym(hp
^.symtableentry
)^.varspez
=vs_const
) then
1104 { allow p^:= constructions with p is const parameter }
1106 valid_for_assign
:=true
1108 CGMessagePos(hp
^.fileinfo
,type_e_no_assign_to_const
);
1111 { Are we at a with symtable, then we need to process the
1112 withrefnode also to check for maybe a const load }
1113 if (hp
^.symtable
^.symtabletype
=withsymtable
) then
1115 { continue with processing the withref node }
1116 hp
:=ptree(pwithsymtable(hp
^.symtable
)^.withrefnode
);
1121 { set the assigned flag for varsyms }
1122 if (pvarsym(hp
^.symtableentry
)^.varstate
=vs_declared
) then
1123 pvarsym(hp
^.symtableentry
)^.varstate
:=vs_assigned
;
1124 valid_for_assign
:=true;
1131 valid_for_assign
:=true;
1138 CGMessagePos(hp
^.fileinfo
,type_e_variable_id_expected
);
1148 Revision 1.1 2002/02/19 08:22:24 sasu
1151 Revision 1.1.2.5 2000/12/09 13:03:47 florian
1152 * web bug 1207 fixed: field and properties of const classes can be
1155 Revision 1.1.2.4 2000/12/08 14:07:13 jonas
1156 * removed curly braces from previous log comment
1158 Revision 1.1.2.3 2000/12/08 10:41:06 jonas
1159 * fix for web bug 1245: arrays of char with size >255 are now passed to
1160 overloaded procedures which expect ansistrings instead of shortstrings
1162 * pointer to array of chars (when using $t+) are now also considered
1165 Revision 1.1.2.2 2000/08/16 18:26:00 peter
1166 * splitted namedobjectitem.next into indexnext and listnext so it
1167 can be used in both lists
1168 * don't allow "word = word" type definitions
1170 Revision 1.1.2.1 2000/08/07 09:19:33 jonas
1171 * fixed bug in type conversions between enum subranges (it didn't take
1172 the packenum directive into account)
1173 + define PACKENUMFIXED symbol in options.pas
1175 Revision 1.1 2000/07/13 06:29:51 michael
1178 Revision 1.71 2000/07/06 18:56:58 peter
1179 * fixed function returning record type and assigning to the result
1181 Revision 1.70 2000/06/18 19:41:19 peter
1182 * fixed pchar<->[string,chararray] operations
1184 Revision 1.69 2000/06/11 07:00:21 peter
1185 * fixed pchar->string conversion for delphi mode
1187 Revision 1.68 2000/06/06 20:25:43 pierre
1188 * unary minus operator overloading was broken
1189 + accept pointer args in binary operator
1191 Revision 1.67 2000/06/05 20:41:17 pierre
1192 + support for NOT overloading
1193 + unsupported overloaded operators generate errors
1195 Revision 1.66 2000/06/04 09:04:30 peter
1196 * check for procvar in valid_for_formal
1198 Revision 1.65 2000/06/02 21:22:04 pierre
1199 + isbinaryoperatoracceptable and isunaryoperatoracceptable
1200 for a more coherent operator overloading implementation
1201 tok2node moved from pexpr unit to htypechk
1203 Revision 1.64 2000/06/01 19:13:02 peter
1204 * fixed long line for tp7
1206 Revision 1.63 2000/06/01 11:00:52 peter
1207 * fixed string->pchar conversion for array constructors
1209 Revision 1.62 2000/05/30 18:38:45 florian
1210 * fixed assignments of subrange enumeration types
1212 Revision 1.61 2000/05/26 18:21:41 peter
1213 * give error for @ with formal const,var parameter. Because @ generates
1214 a constant value and not a reference
1216 Revision 1.60 2000/05/16 16:01:03 florian
1217 * fixed type conversion test for open arrays: the to and from fields where
1218 exchanged which leads under certain circumstances to problems when
1219 passing arrays of classes/class references as open array parameters
1221 Revision 1.59 2000/02/18 16:13:29 florian
1222 * optimized ansistring compare with ''
1225 Revision 1.58 2000/02/09 13:22:53 peter
1228 Revision 1.57 2000/02/05 12:11:50 peter
1229 * property check for assigning fixed for calln
1231 Revision 1.56 2000/02/01 09:41:27 peter
1232 * allow class -> voidpointer for delphi mode
1234 Revision 1.55 2000/01/07 01:14:27 peter
1235 * updated copyright to 2000
1237 Revision 1.54 1999/12/31 14:26:27 peter
1238 * fixed crash with empty array constructors
1240 Revision 1.53 1999/12/18 14:55:21 florian
1241 * very basic widestring support
1243 Revision 1.52 1999/12/16 19:12:04 peter
1244 * allow constant pointer^ also for assignment
1246 Revision 1.51 1999/12/09 09:35:54 peter
1247 * allow assigning to self
1249 Revision 1.50 1999/11/30 10:40:43 peter
1252 Revision 1.49 1999/11/18 15:34:45 pierre
1253 * Notes/Hints for local syms changed to
1254 Set_varstate function
1256 Revision 1.48 1999/11/09 14:47:03 peter
1257 * pointer->array is allowed for all pointer types in FPC, fixed assign
1260 Revision 1.47 1999/11/09 13:29:33 peter
1261 * valid_for_assign allow properties with calln
1263 Revision 1.46 1999/11/08 22:45:33 peter
1264 * allow typecasting to integer within pointer typecast+deref
1266 Revision 1.45 1999/11/06 14:34:21 peter
1267 * truncated log to 20 revs
1269 Revision 1.44 1999/11/04 23:11:21 peter
1270 * fixed pchar and deref detection for assigning
1272 Revision 1.43 1999/10/27 16:04:45 peter
1273 * valid_for_assign support for calln,asn
1275 Revision 1.42 1999/10/26 12:30:41 peter
1276 * const parameter is now checked
1277 * better and generic check if a node can be used for assigning
1279 * procvar equal works now (it never had worked at least from 0.99.8)
1280 * defcoll changed to linkedlist with pparaitem so it can easily be
1281 walked both directions
1283 Revision 1.41 1999/10/14 14:57:52 florian
1284 - removed the hcodegen use in the new cg, use cgbase instead
1286 Revision 1.40 1999/09/26 21:30:15 peter
1287 + constant pointer support which can happend with typecasting like
1289 * better procvar parsing in typed consts
1291 Revision 1.39 1999/09/17 17:14:04 peter
1292 * @procvar fixes for tp mode
1293 * @<id>:= gives now an error
1295 Revision 1.38 1999/08/17 13:26:07 peter
1296 * arrayconstructor -> arrayofconst fixed when arraycosntructor was not