Merge branch 'inheritance'

changelog.txt

@@ -16,6 +16,9 @@ Version 0.24.0:
 - fbc can now be built for installation into MinGW/DJGPP
 - Support for windres instead of GoRC when installing into MinGW or cross-compiling from a non-win32 system
 - The .def file generated when building a DLL is now preserved if -R was given
+- Single inheritance for classes: TYPE Child EXTENDS Parent
+- BASE keyword for explicit base class access inside methods: BASE.member (as opposed to THIS.member)
+- Runtime type information (RTTI) for classes extending other classes or the new builtin OBJECT class: IF variable IS SomeClass THEN ...
 
 [fixed]
 - Subtracting pointers from numbers, e.g. (i-p) was being allowed, rearranging to (p-i)

compiler/ast-misc.bas

@@ -840,7 +840,7 @@ function astPtrCheck _
     end if
 
 	'' check sub types
-	function = symbIsEqual( psubtype, astGetSubType( expr ) )
+	function = symbIsEqual( astGetSubType( expr ), psubtype )
 
 end function
 

compiler/ast-node-arg.bas

@@ -790,11 +790,26 @@ private function hCheckUDTParam _
 
     '' check for invalid UDT's (different subtypes)
 	if( symbGetSubtype( param ) <> arg->subtype ) then
-		if( hImplicitCtor( parent, param, n ) = FALSE ) then
-			hParamError( parent )
-			return FALSE
+		'' param is not a base type of arg?
+		if( symbGetUDTBaseLevel( arg->subtype, symbGetSubtype( param ) ) = 0 ) then
+			'' no ctor in the param's type?
+			if( hImplicitCtor( parent, param, n ) = FALSE ) then
+				'' no cast operator? 
+				arg = astNewCONV( symbGetType( param ), symbGetSubtype( param ), arg )
+				if( arg = NULL ) then
+					hParamError( parent )
+					return FALSE
+				end if
+				n->l = arg
+			else
+				'' Found matching param.ctor to create param from arg
+				return TRUE
+			end if
+		'' cast to the base type
+		else
+			arg = astNewCONV( symbGetType( param ), symbGetSubtype( param ), arg )
+			n->l = arg
 		end if
-		return TRUE
 	end if
 
 	select case symbGetParamMode( param )
@@ -1047,7 +1062,19 @@ private function hCheckParam _
 			if( typeIsPtr( arg_dtype ) = FALSE ) then
 				hParamWarning( parent, FB_WARNINGMSG_PASSINGSCALARASPTR )
 			else
-				hParamWarning( parent, FB_WARNINGMSG_PASSINGDIFFPOINTERS )
+				'' if both are UDT, a base param can't be passed to a derived arg
+				if( typeGetDtOnly( param_dtype ) = FB_DATATYPE_STRUCT and typeGetDtOnly( arg_dtype ) = FB_DATATYPE_STRUCT ) then
+					if( symbGetUDTBaseLevel( symbGetSubtype( param ), astGetSubType( arg ) ) > 0 ) then
+						hParamError( parent, FB_ERRMSG_INVALIDDATATYPES )
+						exit function
+					else
+						hParamWarning( parent, FB_WARNINGMSG_PASSINGDIFFPOINTERS )
+					End If
+
+				else
+					hParamWarning( parent, FB_WARNINGMSG_PASSINGDIFFPOINTERS )
+				end if
+
 			end if
 		end if
 

compiler/ast-node-assign.bas

@@ -63,8 +63,9 @@ private function hCheckUDTOps _
 	( _
 		byval l as ASTNODE ptr, _
 		byval ldclass as FB_DATACLASS, _
-		byval r as ASTNODE ptr, _
-		byval rdclass as FB_DATACLASS _
+		byref r as ASTNODE ptr, _
+		byval rdclass as FB_DATACLASS, _
+		byval checkOnly as integer = TRUE _ 
 	) as integer
 
 	dim as FBSYMBOL ptr proc = any
@@ -88,7 +89,15 @@ private function hCheckUDTOps _
 
    	'' different subtypes?
 	if( l->subtype <> r->subtype ) then
-		exit function
+		'' check if lhs is a base type of rhs
+		if( symbGetUDTBaseLevel( r->subtype, l->subtype ) = 0 ) then
+			exit function
+		End If
+
+		'' cast to the base type
+		if( checkOnly = FALSE ) then
+			r = astNewCONV( astGetDataType( l ), l->subtype, r )
+		end if
 	end if
 
 	function = TRUE
@@ -222,8 +231,16 @@ private sub hCheckConstAndPointerOps _
 
 	if( typeIsPtr( ldtype ) ) then
 		if( astPtrCheck( ldtype, l->subtype, r ) = FALSE ) then
-			errReportWarn( FB_WARNINGMSG_SUSPICIOUSPTRASSIGN )
+			'' if both are UDT, a derived lhs can't be assigned from a base rhs
+			if( typeGetDtOnly( ldtype ) = FB_DATATYPE_STRUCT and typeGetDtOnly( rdtype ) = FB_DATATYPE_STRUCT ) then
+				if( symbGetUDTBaseLevel( astGetSubType( l ), astGetSubType( r ) ) > 0 ) then
+					errReport( FB_ERRMSG_ILLEGALASSIGNMENT, TRUE )
+					return
+				end if
+				errReportWarn( FB_WARNINGMSG_SUSPICIOUSPTRASSIGN )
+			end if
 		end if
+
 	'' r-side expr is a ptr?
 	elseif( typeIsPtr( rdtype ) ) then
 		errReportWarn( FB_WARNINGMSG_IMPLICITCONVERSION )
@@ -268,7 +285,7 @@ function astCheckASSIGN _
 	elseif( (ldtype = FB_DATATYPE_STRUCT) or _
 			(rdtype = FB_DATATYPE_STRUCT) ) then
 
-		if( hCheckUDTOps( l, ldclass, r, rdclass ) = FALSE ) then
+		if( hCheckUDTOps( l, ldclass, r, rdclass, TRUE ) = FALSE ) then
 			exit function
 		end if
 
@@ -476,7 +493,7 @@ function astNewASSIGN _
 	elseif( (ldtype = FB_DATATYPE_STRUCT) or _
 			(rdtype = FB_DATATYPE_STRUCT) ) then
 
-		if( hCheckUDTOps( l, ldclass, r, rdclass ) = FALSE ) then
+		if( hCheckUDTOps( l, ldclass, r, rdclass, FALSE ) = FALSE ) then
 			exit function
 		end if
 

compiler/ast-node-bop.bas

@@ -847,6 +847,19 @@ end function
 
 #endmacro
 
+'':::::
+private function hCmpDynType _
+	( _
+		byval l as ASTNODE ptr, _
+		byval r as ASTNODE ptr _
+	) as ASTNODE ptr
+
+	'' all checks already done at parser level
+
+	return rtlOOPIsTypeOf( l, r )
+
+End Function
+
 '':::::
 function astNewBOP _
 	( _
@@ -870,11 +883,15 @@ function astNewBOP _
 
 	is_str = FALSE
 
-	'' special case..
-	if( op = AST_OP_CONCAT ) then
+	'' special cases..
+	select case op
+	case AST_OP_CONCAT
 		hToStr( l, r )
 		op = AST_OP_ADD
-	end if
+
+	case AST_OP_IS
+		return hCmpDynType( l, r )
+	End Select
 
 	ldtype = astGetFullType( l )
 	rdtype = astGetFullType( r )

compiler/ast-node-conv.bas

@@ -265,6 +265,7 @@ end sub
 private function hCheckPtr _
 	( _
 		byval to_dtype as integer, _
+		byval to_subtype as FBSYMBOL ptr, _
 		byval expr_dtype as integer, _
 		byval expr as ASTNODE ptr _
 	) as integer
@@ -305,8 +306,46 @@ private function hCheckPtr _
 				exit function
 			end if
 		end select
+
 	end if
 
+	'' if any of them is a derived class, only allow cast to a base or derived
+	if( typeGetDtOnly( to_dtype ) = FB_DATATYPE_STRUCT ) then
+		if( to_subtype->udt.base <> NULL ) then
+			if( typeGetDtOnly( expr_dtype ) <> FB_DATATYPE_STRUCT ) then
+				if( typeGetDtOnly( expr_dtype ) <> FB_DATATYPE_VOID ) then
+					exit function
+				end if
+			else			
+				'' not a upcasting?
+				if( symbGetUDTBaseLevel( expr->subtype, to_subtype ) = 0 ) then
+					'' try downcasting..
+					if( symbGetUDTBaseLevel( to_subtype, expr->subtype ) = 0 ) then
+						exit function
+					End If
+				End If
+			end if
+		End If
+	End If
+
+	if( typeGetDtOnly( expr_dtype ) = FB_DATATYPE_STRUCT ) then		
+		if( expr->subtype->udt.base <> NULL ) then
+			if( typeGetDtOnly( to_dtype ) <> FB_DATATYPE_STRUCT ) then
+				if( typeGetDtOnly( to_dtype ) <> FB_DATATYPE_VOID ) then
+					exit function
+				end if
+			else
+				'' not a upcasting?
+				if( symbGetUDTBaseLevel( to_subtype, expr->subtype ) = 0 ) then
+					'' try downcasting..
+					if( symbGetUDTBaseLevel( expr->subtype, to_subtype ) = 0 ) then
+						exit function
+					End If
+				End If
+			end if
+		End If
+	End If
+
 	function = TRUE
 
 end function
@@ -323,9 +362,9 @@ function astCheckCONV _
 
 	function = FALSE
 
-	'' UDT? can't convert..
+	'' UDT? only upcasting supported by now
 	if( typeGet( to_dtype ) = FB_DATATYPE_STRUCT ) then
-		exit function
+		return symbGetUDTBaseLevel( l->subtype, to_subtype ) > 0
 	end if
 
 	ldtype = astGetFullType( l )
@@ -336,7 +375,7 @@ function astCheckCONV _
 	end if
 
 	'' check pointers
-	if( hCheckPtr( to_dtype, ldtype, l ) = FALSE ) then
+	if( hCheckPtr( to_dtype, to_subtype, ldtype, l ) = FALSE ) then
 		exit function
 	end if
 
@@ -405,9 +444,13 @@ function astNewCONV _
 	select case as const typeGet( to_dtype )
 	'' to UDT? as op overloading failed, refuse.. ditto with void (used by uop/bop
 	'' to cast to be most precise possible) and strings
-	case FB_DATATYPE_VOID, FB_DATATYPE_STRING, _
-		 FB_DATATYPE_STRUCT ', FB_DATATYPE_CLASS
+	case FB_DATATYPE_VOID, FB_DATATYPE_STRING
 		exit function
+
+	case FB_DATATYPE_STRUCT ', FB_DATATYPE_CLASS
+		if( symbGetUDTBaseLevel( l->subtype, to_subtype ) = 0 ) then
+			exit function
+		End If
 
 	case else
 		select case typeGet( ldtype )
@@ -430,7 +473,7 @@ function astNewCONV _
 	end select
 
 	'' check pointers
-	if( hCheckPtr( to_dtype, ldtype, l ) = FALSE ) then
+	if( hCheckPtr( to_dtype, to_subtype, ldtype, l ) = FALSE ) then
 		exit function
 	end if
 
@@ -497,15 +540,27 @@ function astNewCONV _
 	    '' special case: if it's a float to int, use a builtin function
 	    if (ldclass = FB_DATACLASS_FPOINT) and ( symbGetDataClass( to_dtype ) = FB_DATACLASS_INTEGER ) then
         	return rtlMathFTOI( l, to_dtype )
+        else			
+        	select case typeGetDtAndPtrOnly( to_dtype )
+			case FB_DATATYPE_STRUCT '', FB_DATATYPE_CLASS
+				'' C (not C++) doesn't support casting from a UDT to another, so do this instead: lhs = *((typeof(lhs)*)&rhs)
+				return astNewDEREF( astNewCONV( typeAddrOf( to_dtype ), to_subtype, astNewADDROF( l ) ) )   
+			end select
         end if
 
 	else
 		'' only convert if the classes are different (ie, floating<->integer) or
 		'' if sizes are different (ie, byte<->int)
 		if( ldclass = symbGetDataClass( to_dtype ) ) then
-			if( symbGetDataSize( ldtype ) = symbGetDataSize( to_dtype ) ) then
+			select case typeGet( to_dtype )
+			case FB_DATATYPE_STRUCT '', FB_DATATYPE_CLASS   
+				'' do nothing
 				doconv = FALSE
-			end if
+			case else
+				if( symbGetDataSize( ldtype ) = symbGetDataSize( to_dtype ) ) then
+					doconv = FALSE
+				end if
+			End Select
 		end if
 
 		if( irGetOption( IR_OPT_FPU_CONVERTOPER ) ) then