fbc: add PROCPTR( UDT.member [VIRTUAL] [,signature] )

- allow getting the offset in the virtual table (in bytes) of the
  virtual member procedure
- if the member procedure is not virtual or abstract then return
  special offset of -(2147483648u) to indicate there is no virtual
  table entry and do not throw a a compile error.  Because this is
  a low-level bit of information, user will need to deal with it
  in their source anyway
- The combination of member procedure and/or virtual table offset
  should allow for rudimentary albeit somewhat restricted low level
  delegate like operations implemented in user code

Example:
	type B extends object
		declare abstract sub proc1()
		declare abstract sub proc2()
	end type

	type D extends B
		declare virtual sub proc2()
		declare virtual sub proc1()
	end type

	sub D.proc1()
		print "D.proc1"
	end sub

	sub D.proc2()
		print "D.proc2"
	end sub

	var fptr = procptr( B.proc2 )           '' address = NULL, because abstract
	var ofst = procptr( B.proc2, virtual )  '' offset >= 0 because it's in the virtual table
	var inst = new D                        '' create an instance

	'' have offset in virtual table? Do a virtual table look-up
	if( ofst >= 0 ) then
		fptr = cptr( typeof(fptr), (*cast( any ptr ptr ptr, inst ))[ofst\sizeof(any ptr)] )
	end if

	'' call the procedure
	fptr( *inst )                 '' OUTPUT: D.proc2

changelog.txt

@@ -68,6 +68,7 @@ Version 1.10.0
 - fbc: allow typename.member symbol checks for #ifdef / #ifndef / defined() where member can be a data field, static data field, nested type, constructor, destructor, property, operator (self-assignment, new, new[], delete, delete[], let, cast, for, step, next), or member procedure.
 - rtlib: dos: add "__fb_dos_no_dpmi_yield" variable to control calling "__dpmi_yield()" and prevent a crash under some dos extenders in dosbox
 - fbc: PROCPTR( UDT.member [, SUB|FUNCTION ...] ) to get a procedure pointer for type member procedures.  If the member is abstract, then return 0 (null function pointer of the member procedure's call signature)
+- fbc: PROCPTR( UDT.member VIRTUAL [, SUB|FUNCTION ...] ) to get the offset (in bytes) in to the virtual table.  If there is no virtual table entry (or no virtual table at all) then return the special value of -2147483648
 
 [fixed]
 - gas64: missing restoring of use of one virtual register on sqr for float (SARG)

src/compiler/parser-expr-unary.bas

@@ -491,7 +491,8 @@ private function hProcPtrBody _
 	( _
 		byval base_parent as FBSYMBOL ptr, _
 		byval proc as FBSYMBOL ptr, _
-		byval check_exact as boolean _
+		byval check_exact as boolean, _
+		byval is_vtable_offset as integer _
 	) as ASTNODE ptr
 
 	assert( proc <> NULL )
@@ -524,19 +525,35 @@ private function hProcPtrBody _
 		callback( proc )
 	end if
 
+	if( is_vtable_offset ) then
+		'' if not virtual or abstract then procedure doesn't exist in
+		'' the virtual table.  Don't throw an error, just return an
+		'' invalid vtable offset.  vtable offsets are something that
+		'' the user will have to deal with anyway
+		dim as integer vtableoffset = -2147483648u
+
+		if( symbIsAbstract( proc ) or symbIsVirtual( proc ) ) then
+			vtableoffset = ( symbProcGetVtableIndex( proc ) - 2 ) * env.pointersize
+		endif
+
+		var expr = astNewCONSTi( vtableoffset )
+		return expr
+	end if
+
 	if( symbIsAbstract( proc ) )then
 		'' member is abstract and is not something we can get the address of
 		'' until a virtual lookup at runtime ...
 		'' return a null pointer of the function pointer instead
 
-		var expr = astNewCONSTi( 0, FB_DATATYPE_INTEGER, NULL )
+		var expr = astNewCONSTi( 0 )
 		expr = astNewCONV( typeAddrOf( FB_DATATYPE_FUNCTION ), symbAddProcPtrFromFunction( proc ), expr )
 		return expr
 	end if
 
 	return astBuildProcAddrof( proc )
 end function
 
+'' PROCPTR '(' Proc ('('')')? VIRTUAL? ( ',' signature )? ')'
 function cProcPtrBody _
 	( _
 		byval dtype as integer, _
@@ -546,6 +563,7 @@ function cProcPtrBody _
 	dim as FBSYMCHAIN ptr chain_ = any
 	dim as FBSYMBOL ptr sym = any, base_parent = any
 	dim as ASTNODE ptr expr = any
+	dim as integer is_vtable_offset = FALSE
 
 	if( dtype = FB_DATATYPE_STRUCT ) then
 		base_parent = subtype
@@ -579,10 +597,16 @@ function cProcPtrBody _
 
 	'' ','?
 	if( hMatch( CHAR_COMMA ) ) then
-		dim as integer dtype = any
-		dim as FBSYMBOL ptr subtype = any
+		dim as integer dtype = FB_DATATYPE_VOID
+		dim as FBSYMBOL ptr subtype = NULL
 		dim as integer is_exact = FALSE
 
+		'' VIRTUAL?
+		if( lexGetToken( ) = FB_TK_VIRTUAL ) then
+			is_vtable_offset = TRUE
+			lexSkipToken( LEXCHECK_POST_SUFFIX )
+		end if
+
 		'' only if anything but ')' follows...
 		if( lexGetToken( ) <> CHAR_RPRNT ) then
 			if( cSymbolType( dtype, subtype ) = FALSE ) then
@@ -610,13 +634,13 @@ function cProcPtrBody _
 		parser.ctxsym = subtype
 		parser.ctx_dtype = dtype
 
-		expr = hProcPtrBody( base_parent, sym, is_exact )
+		expr = hProcPtrBody( base_parent, sym, is_exact, is_vtable_offset )
 
 		parser.ctxsym = oldsym
 		parser.ctx_dtype = old_dtype
 
 	else
-		expr = hProcPtrBody( base_parent, sym, FALSE )
+		expr = hProcPtrBody( base_parent, sym, FALSE, is_vtable_offset )
 	end if
 
 	return expr
@@ -723,7 +747,7 @@ function cAddrOfExpression( ) as ASTNODE ptr
 		if( sym <> NULL ) then
 			lexSkipToken( LEXCHECK_POST_LANG_SUFFIX )
 			hCheckEmptyProcParens()
-			return hProcPtrBody( base_parent, sym, FALSE )
+			return hProcPtrBody( base_parent, sym, FALSE, FALSE )
 		end if
 
 		'' anything else
@@ -752,7 +776,7 @@ function cAddrOfExpression( ) as ASTNODE ptr
 			hSkipUntil( CHAR_RPRNT, TRUE )
 		end if
 
-	'' PROCPTR '(' Proc ('('')')? ( ',' signature )? ')'
+	'' PROCPTR '(' Proc ('('')')? VIRTUAL? ( ',' signature )? ')'
 	case FB_TK_PROCPTR
 		lexSkipToken( LEXCHECK_POST_SUFFIX )
 

tests/pointers/procptr-low-level-delegate.bas

@@ -0,0 +1,278 @@
+#include "fbcunit.bi"
+
+SUITE( fbc_tests.pointers.procptr_low_level_delegate )
+
+	dim shared id as string
+
+	#macro decl_delegate( delegateName, typeName, procName, signature... )
+		type delegateName
+			#if __FB_ARG_COUNT__( signature ) = 0
+				proc as typeof( procptr( typeName.procName ) )
+			#else
+				proc as typeof( procptr( typeName.procName, signature ) )
+			#endif
+			ofst as integer
+			inst as typeName ptr
+		end type
+	#endmacro
+
+	#macro init_delegate( delegate, instance, typeName, procName, signature... )
+		#if __FB_ARG_COUNT__( signature ) = 0
+			delegate.proc = procptr( typeName.procName )
+			delegate.ofst = procptr( typeName.procName, virtual )
+		#else
+			delegate.proc = procptr( typeName.procName, signature )
+			delegate.ofst = procptr( typeName.procName, virtual signature )
+		#endif
+		delegate.inst = instance
+	#endmacro
+
+	#macro call_delegate( delegate, args... )
+		__FB_IIF__( _
+			__FB_ARG_COUNT__( args ) = 0, _
+			iif( _
+				delegate.ofst >= 0, _
+				cptr( typeof(delegate.proc), (*cast( any ptr ptr ptr, delegate.inst ))[delegate.ofst\sizeof(any ptr)] ), _
+				delegate.proc _
+			)( *(delegate.inst) ), _
+			iif( _
+				delegate.ofst >= 0, _
+				cptr( typeof(delegate.proc), (*cast( any ptr ptr ptr, delegate.inst ))[delegate.ofst\sizeof(any ptr)] ), _
+				delegate.proc _
+			)( *(delegate.inst), args ) _
+		)
+	#endmacro
+
+	type T
+		__ as integer
+		declare sub proc1()
+		declare sub proc2()
+	end type
+
+	sub T.proc1()
+		id = "T.proc1"
+	end sub
+
+	sub T.proc2()
+		id = "T.proc2"
+	end sub
+
+	type B extends object
+		declare abstract sub proc1()
+		declare virtual  sub proc2()
+		declare          sub proc3()
+	end type
+
+	sub B.proc2()
+		id = "B.proc2"
+	end sub
+
+	sub B.proc3()
+		id = "B.proc3"
+	end sub
+
+	type D1 extends B
+		declare abstract sub proc1()
+		declare abstract sub proc2()
+		declare abstract sub proc3()
+	end type
+
+	type D2 extends B
+		declare virtual  sub proc1()
+		declare virtual  sub proc2()
+		declare virtual  sub proc3()
+	end type
+
+	sub D2.proc1()
+		id = "D2.proc1"
+	end sub
+
+	sub D2.proc2()
+		id = "D2.proc2"
+	end sub
+
+	sub D2.proc3()
+		id = "D2.proc3"
+	end sub
+
+	type D3 extends B
+		declare          sub proc1()
+		declare          sub proc2()
+		declare          sub proc3()
+	end type
+
+	sub D3.proc1()
+		id = "D3.proc1"
+	end sub
+
+	sub D3.proc2()
+		id = "D3.proc2"
+	end sub
+
+	sub D3.proc3()
+		id = "D3.proc3"
+	end sub
+
+	'' call member proc of non-virtual
+	TEST( non_virtual_1 )
+		decl_delegate( Delegate_T_proc1, T, proc1 )
+		dim d as Delegate_T_proc1 = any
+
+		dim x as T
+		init_delegate( d, @x, T, proc1 )
+
+		call_delegate( d )
+		CU_ASSERT_EQUAL( id, "T.proc1" )
+	END_TEST
+
+	'' call member proc of non-virtual
+	TEST( non_virtual_2 )
+		decl_delegate( Delegate_T_proc2, T, proc2 )
+		dim d as Delegate_T_proc2 = any
+
+		dim x as T
+		init_delegate( d, @x, T, proc2 )
+
+		call_delegate( d )
+		CU_ASSERT_EQUAL( id, "T.proc2" )
+	END_TEST
+
+	/' not allowed
+	'' call member proc of base.abstract / derived.abstract
+	scope
+		decl_delegate( Delegate_B_proc1, B, proc1 )
+		dim d as Delegate_B_proc1 = any
+
+		dim x as D1
+		init_delegate( d, @x, D1, proc1 )
+
+		call_delegate( d )
+		CU_ASSERT_EQUAL( id, "D1.proc1" )
+	end scope
+	'/
+
+	/' not allowed
+	'' call member proc of base.virtual / derived.abstract
+	scope
+		decl_delegate( Delegate_B_proc2, B, proc2 )
+		dim d as Delegate_B_proc2 = any
+
+		dim x as D1
+		init_delegate( d, @x, D1, proc2 )
+
+		call_delegate( d )
+		CU_ASSERT_EQUAL( id, "D1.proc2" )
+	end scope
+	'/
+
+	/' not allowed
+	'' call member proc of base.non-virtual / derived.abstract
+	scope
+		decl_delegate( Delegate_B_proc3, B, proc3 )
+		dim d as Delegate_B_proc3 = any
+
+		dim x as D1
+		init_delegate( d, @x, B, proc3 )
+
+		call_delegate( d )
+		CU_ASSERT_EQUAL( id, "D1.proc3" )
+	end scope
+	'/
+
+	'' call member proc of base.abstract / derived.virtual
+	TEST( abstract_virtual_1 )
+		decl_delegate( Delegate_B_proc1, B, proc1 )
+		dim d as Delegate_B_proc1 = any
+
+		dim x as D2
+		init_delegate( d, @x, B, proc1 )
+
+		call_delegate( d )
+		CU_ASSERT_EQUAL( id, "D2.proc1" )
+	END_TEST
+
+	'' call member proc of base.virtual / derived.virtual
+	TEST( virtual_virtual )
+		decl_delegate( Delegate_B_proc2, B, proc2 )
+		dim d as Delegate_B_proc2 = any
+
+		dim x as D2
+		init_delegate( d, @x, B, proc2 )
+
+		call_delegate( d )
+		CU_ASSERT_EQUAL( id, "D2.proc2" )
+	END_TEST
+
+	'' call member proc of base.non-virtual / derived.virtual
+	TEST( non_virtual_virtual )
+		decl_delegate( Delegate_D2_proc3, D2, proc3 )
+		dim d as Delegate_D2_proc3 = any
+
+		dim x as D2
+		init_delegate( d, @x, D2, proc3 )
+
+		call_delegate( d )
+		CU_ASSERT_EQUAL( id, "D2.proc3" )
+	END_TEST
+
+	'' call member proc of base.abstract / derived.virtual
+	TEST( abstract_virtual )
+		decl_delegate( Delegate_B_proc1, B, proc1 )
+		dim d as Delegate_B_proc1 = any
+
+		dim x as D3
+		init_delegate( d, @x, B, proc1 )
+
+		call_delegate( d )
+		CU_ASSERT_EQUAL( id, "D3.proc1" )
+	END_TEST
+
+	'' call member proc of base.virtual / derived.non-virtual
+	TEST( virtual_non_virtual )
+		decl_delegate( Delegate_B_proc2, B, proc2 )
+		dim d as Delegate_B_proc2 = any
+
+		dim x as D3
+		init_delegate( d, @x, B, proc2 )
+
+		call_delegate( d )
+		CU_ASSERT_EQUAL( id, "D3.proc2" )
+	END_TEST
+
+	'' call member proc of base.non-virtual / derived.non-virtual
+	TEST( non_virtual_non_virtual1 )
+		decl_delegate( Delegate_B_proc3, B, proc3 )
+		dim d as Delegate_B_proc3 = any
+
+		dim x as D3
+		init_delegate( d, @x, B, proc3 )
+
+		call_delegate( d )
+		CU_ASSERT_EQUAL( id, "B.proc3" )
+	END_TEST
+
+	'' call member proc of base.non-virtual / derived.non-virtual
+	TEST( non_virtual_non_virtual2 )
+		decl_delegate( Delegate_D3_proc3, D3, proc3 )
+		dim d as Delegate_D3_proc3 = any
+
+		dim x as D3
+		init_delegate( d, @x, D3, proc3 )
+
+		call_delegate( d )
+		CU_ASSERT_EQUAL( id, "D3.proc3" )
+	END_TEST
+
+	'' call member proc of base.non-virtual / derived.non-virtual
+	TEST( non_virtual_non_virtual3 )
+		decl_delegate( Delegate_D3_proc3, D3, proc3 )
+		dim d as Delegate_D3_proc3 = any
+
+		dim x as D3
+		init_delegate( d, @x, D3, proc3 )
+
+		call_delegate( d )
+		CU_ASSERT_EQUAL( id, "D3.proc3" )
+	END_TEST
+
+END_SUITE