From 6171784cdff56d501db16b325573d73b615d4cfa Mon Sep 17 00:00:00 2001 From: v1ctor Date: Fri, 25 Mar 2011 23:24:41 +0000 Subject: [PATCH 01/17] added: inheritance (WIP) r5464 --- FreeBASIC/src/compiler/ast-node-arg.bas | 17 ++++-- FreeBASIC/src/compiler/ast-node-conv.bas | 22 +++++--- FreeBASIC/src/compiler/error.bas | 3 +- FreeBASIC/src/compiler/inc/error.bi | 1 + FreeBASIC/src/compiler/inc/fbint.bi | 3 ++ FreeBASIC/src/compiler/inc/symb.bi | 20 +++++-- FreeBASIC/src/compiler/parser-decl-struct.bas | 53 +++++++++++++++++-- FreeBASIC/src/compiler/symb-keyword.bas | 3 ++ FreeBASIC/src/compiler/symb-namespace.bas | 19 ++++--- FreeBASIC/src/compiler/symb-struct.bas | 23 +++++++- FreeBASIC/src/compiler/symb.bas | 22 ++++++-- 11 files changed, 157 insertions(+), 29 deletions(-) diff --git a/FreeBASIC/src/compiler/ast-node-arg.bas b/FreeBASIC/src/compiler/ast-node-arg.bas index 882783e59d..0ce42b58c6 100644 --- a/FreeBASIC/src/compiler/ast-node-arg.bas +++ b/FreeBASIC/src/compiler/ast-node-arg.bas @@ -808,10 +808,21 @@ 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 + + if( symbIsUDTBaseOf( arg->subtype, symbGetSubtype( param ) ) = FALSE ) then + hParamError( parent ) + return FALSE + else + n->l = astNewCONV( symbGetType( param ), symbGetSubtype( param ), arg ) + if( n->l = NULL ) then + hParamError( parent ) + return FALSE + End If + End If + + else + return TRUE end if - return TRUE end if select case symbGetParamMode( param ) diff --git a/FreeBASIC/src/compiler/ast-node-conv.bas b/FreeBASIC/src/compiler/ast-node-conv.bas index be2e28875d..bd1230df7c 100644 --- a/FreeBASIC/src/compiler/ast-node-conv.bas +++ b/FreeBASIC/src/compiler/ast-node-conv.bas @@ -340,9 +340,9 @@ function astCheckCONV _ function = FALSE - '' UDT? can't convert.. + '' UDT? only downcasting supported by now if( typeGet( to_dtype ) = FB_DATATYPE_STRUCT ) then - exit function + return symbIsUDTBaseOf( l->subtype, to_subtype ) end if ldtype = astGetFullType( l ) @@ -422,9 +422,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( symbIsUDTBaseOf( l->subtype, to_subtype ) = FALSE ) then + exit function + End If case else select case typeGet( ldtype ) @@ -520,9 +524,15 @@ function astNewCONV _ '' 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 diff --git a/FreeBASIC/src/compiler/error.bas b/FreeBASIC/src/compiler/error.bas index 220d427db3..5f8fcae612 100644 --- a/FreeBASIC/src/compiler/error.bas +++ b/FreeBASIC/src/compiler/error.bas @@ -309,7 +309,8 @@ end type @"FOR/NEXT variable name mismatch", _ @"Selected option requires an SSE FPU mode", _ @"Expected relational operator ( =, >, <, <>, <=, >= )", _ - @"Unsupported statement in -gen gcc mode" _ + @"Unsupported statement in -gen gcc mode", _ + @"TYPE can only extend other TYPE symbols" _ } diff --git a/FreeBASIC/src/compiler/inc/error.bi b/FreeBASIC/src/compiler/inc/error.bi index 2bf173c6a0..592b4b6092 100644 --- a/FreeBASIC/src/compiler/inc/error.bi +++ b/FreeBASIC/src/compiler/inc/error.bi @@ -258,6 +258,7 @@ enum FB_ERRMSG FB_ERRMSG_OPTIONREQUIRESSSE FB_ERRMSG_EXPECTEDRELOP FB_ERRMSG_STMTUNSUPPORTEDINGCC + FB_ERRMSG_EXPECTEDCLASSTYPE FB_ERRMSGS end enum diff --git a/FreeBASIC/src/compiler/inc/fbint.bi b/FreeBASIC/src/compiler/inc/fbint.bi index d7ae75b58f..b50f9d269e 100644 --- a/FreeBASIC/src/compiler/inc/fbint.bi +++ b/FreeBASIC/src/compiler/inc/fbint.bi @@ -356,6 +356,9 @@ enum FB_TOKEN FB_TK_DESTRUCTOR FB_TK_OPERATOR FB_TK_PROPERTY + FB_TK_EXTENDS + FB_TK_IMPLEMENTS + FB_TK_BASE FB_TK_BYTE FB_TK_UBYTE diff --git a/FreeBASIC/src/compiler/inc/symb.bi b/FreeBASIC/src/compiler/inc/symb.bi index a45f680555..5028809dfd 100644 --- a/FreeBASIC/src/compiler/inc/symb.bi +++ b/FreeBASIC/src/compiler/inc/symb.bi @@ -430,7 +430,8 @@ end type type FBS_STRUCT '' extends FBNAMESCP ns as FBNAMESPC - + + base as FBSYMBOL_ ptr '' base class anonparent as FBSYMBOL_ ptr elements as integer lfldlen as integer '' largest field len @@ -684,8 +685,8 @@ type FBSYMBOL symtb as FBSYMBOLTB ptr '' symbol tb it's part of - parent as FBSYMBOL ptr - + parent as FBSYMBOL Ptr + prev as FBSYMBOL ptr '' next in symbol tb list next as FBSYMBOL ptr '' prev / end type @@ -1596,6 +1597,12 @@ declare function symbNamespaceImport _ byval ns as FBSYMBOL ptr _ ) as integer +declare function symbNamespaceImportEx _ + ( _ + byval ns as FBSYMBOL ptr, _ + byval to_ns as FBSYMBOL ptr _ + ) as integer + declare sub symbNamespaceRemove _ ( _ byval sym as FBSYMBOL ptr, _ @@ -1903,6 +1910,13 @@ declare function symbIsUDTReturnedInRegs _ byval s as FBSYMBOL ptr _ ) as integer +declare function symbIsUDTBaseOf _ + ( _ + byval s as FBSYMBOL ptr, _ + byval baseSym as FBSYMBOL ptr _ + ) as Integer + + '' '' macros diff --git a/FreeBASIC/src/compiler/parser-decl-struct.bas b/FreeBASIC/src/compiler/parser-decl-struct.bas index 71cb9c258d..ac48a8f3fb 100644 --- a/FreeBASIC/src/compiler/parser-decl-struct.bas +++ b/FreeBASIC/src/compiler/parser-decl-struct.bas @@ -689,7 +689,10 @@ private function hTypeAdd _ byval id as zstring ptr, _ byval id_alias as zstring ptr, _ byval isunion as integer, _ - byval align as integer _ + byval align as integer, _ + byval baseDType as integer = FB_DATATYPE_VOID, _ + byval baseSubtype as FBSYMBOL ptr = NULL, _ + byval baseLgt as integer = 0 _ ) as FBSYMBOL ptr dim as FBSYMBOL ptr s = any @@ -720,6 +723,22 @@ private function hTypeAdd _ hSkipUntil( INVALID, TRUE ) end if end if + + '' any extends? + if( baseDType <> FB_DATATYPE_VOID ) then + static as FBARRAYDIM dTB(0 to 0) + + if( symbAddField( s, @"base", _ + 0, dTB(), _ + baseDtype, baseSubtype, _ + baseLgt, 0 ) <> NULL ) then + + s->udt.base = baseSubtype + + symbNamespaceImportEx( baseSubtype, s ) + End If + end if + '' TypeBody dim as integer res = hTypeBody( s ) @@ -1029,7 +1048,7 @@ function hCheckForCDtorOrMethods _ end function ''::::: -''TypeDecl = (TYPE|UNION) ID (ALIAS LITSTR)? (FIELD '=' Expression)? Comment? SttSeparator +''TypeDecl = (TYPE|UNION) ID (ALIAS LITSTR)? (EXTENDS SymbolType)? (FIELD '=' Expression)? Comment? SttSeparator '' TypeLine+ '' END (TYPE|UNION) . function cTypeDecl _ @@ -1143,6 +1162,34 @@ function cTypeDecl _ end select + + '' (EXTENDS SymbolType)? + dim as integer baseDtype, baseLgt + dim as FBSYMBOL ptr baseSubtype = NULL + if( lexGetToken( ) = FB_TK_EXTENDS ) then + lexSkipToken( ) + + '' SymbolType + if( hSymbolType( baseDtype, baseSubtype, baseLgt ) = FALSE ) then + if( errReport( FB_ERRMSG_EXPECTEDIDENTIFIER ) = FALSE ) then + exit function + else + '' error recovery: skip + baseDtype = FB_DATATYPE_VOID + end if + end if + + '' is the base type a struct? + if( baseDType <> FB_DATATYPE_STRUCT ) then + if( errReport( FB_ERRMSG_EXPECTEDCLASSTYPE ) = FALSE ) then + exit function + else + '' error recovery: skip + baseDtype = FB_DATATYPE_VOID + end if + end if + end if + '' (FIELD '=' Expression)? if( lexGetToken( ) = FB_TK_FIELD ) then lexSkipToken( ) @@ -1201,7 +1248,7 @@ function cTypeDecl _ dim as FBSYMBOL ptr currprocsym = parser.currproc, currblocksym = parser.currblock dim as integer scope_depth = parser.scope - sym = hTypeAdd( NULL, id, palias, isunion, align ) + sym = hTypeAdd( NULL, id, palias, isunion, align, baseDtype, baseSubtype, baseLgt ) '' restore the context ast.proc.curr = currproc diff --git a/FreeBASIC/src/compiler/symb-keyword.bas b/FreeBASIC/src/compiler/symb-keyword.bas index 6e3ef1505c..104d13fe0e 100644 --- a/FreeBASIC/src/compiler/symb-keyword.bas +++ b/FreeBASIC/src/compiler/symb-keyword.bas @@ -164,6 +164,9 @@ end type ( @"OPERATOR" , FB_TK_OPERATOR , FB_TKCLASS_KEYWORD , KWD_OPTION_NO_QB ), _ ( @"PROPERTY" , FB_TK_PROPERTY , FB_TKCLASS_KEYWORD , KWD_OPTION_NO_QB ), _ ( @"CLASS" , FB_TK_CLASS , FB_TKCLASS_KEYWORD , KWD_OPTION_NO_QB ), _ + ( @"EXTENDS" , FB_TK_EXTENDS , FB_TKCLASS_KEYWORD , KWD_OPTION_NO_QB ), _ + ( @"IMPLEMENTS" , FB_TK_IMPLEMENTS , FB_TKCLASS_KEYWORD , KWD_OPTION_NO_QB ), _ + ( @"BASE" , FB_TK_BASE , FB_TKCLASS_KEYWORD , KWD_OPTION_NO_QB ), _ ( @"VAR" , FB_TK_VAR , FB_TKCLASS_KEYWORD , KWD_OPTION_NO_QB ), _ ( @"IIF" , FB_TK_IIF , FB_TKCLASS_KEYWORD , KWD_OPTION_NO_QB ), _ ( @"VA_FIRST" , FB_TK_VA_FIRST , FB_TKCLASS_KEYWORD , KWD_OPTION_NO_QB ), _ diff --git a/FreeBASIC/src/compiler/symb-namespace.bas b/FreeBASIC/src/compiler/symb-namespace.bas index 66983328d6..1a8db7316a 100644 --- a/FreeBASIC/src/compiler/symb-namespace.bas +++ b/FreeBASIC/src/compiler/symb-namespace.bas @@ -209,13 +209,18 @@ private function hIsOnImportList _ byval dst_ns as FBSYMBOL ptr _ ) as integer - dim as FBSYMBOL ptr imp_ = symbGetCompImportHead( dst_ns ) - do while( imp_ <> NULL ) - if( symbGetImportNamespc( imp_ ) = src_ns ) then - return TRUE - end if - imp_ = symbGetImportNext( imp_ ) - loop + if( symbGetCompExt( dst_ns ) <> NULL ) Then + + dim as FBSYMBOL ptr imp_ = symbGetCompImportHead( dst_ns ) + + do while( imp_ <> NULL ) + if( symbGetImportNamespc( imp_ ) = src_ns ) then + return TRUE + end if + imp_ = symbGetImportNext( imp_ ) + Loop + + End if function = FALSE diff --git a/FreeBASIC/src/compiler/symb-struct.bas b/FreeBASIC/src/compiler/symb-struct.bas index fc100b46cd..e84be21a23 100644 --- a/FreeBASIC/src/compiler/symb-struct.bas +++ b/FreeBASIC/src/compiler/symb-struct.bas @@ -1021,4 +1021,25 @@ function symbIsUDTReturnedInRegs _ end function - +''::::: +function symbIsUDTBaseOf _ + ( _ + byval s as FBSYMBOL ptr, _ + byval baseSym as FBSYMBOL ptr _ + ) as Integer + + if( s = NULL or baseSym = NULL ) then + return FALSE + end if + + do until( s->udt.base = NULL ) + if( s->udt.base = baseSym ) then + return TRUE + End If + + s = s->udt.base + Loop + + return FALSE + +End Function diff --git a/FreeBASIC/src/compiler/symb.bas b/FreeBASIC/src/compiler/symb.bas index 3a82427c66..3bec9bc283 100644 --- a/FreeBASIC/src/compiler/symb.bas +++ b/FreeBASIC/src/compiler/symb.bas @@ -1929,14 +1929,14 @@ function symbIsChildOf _ ) as integer do - if( sym = parent ) then - return TRUE - end if - if( sym = @symbGetGlobalNamespc( ) ) then return FALSE end if + if( sym = parent ) then + return TRUE + end if + sym = symbGetNamespace( sym ) loop @@ -1952,11 +1952,23 @@ function symbCheckAccess _ ) as integer if( sym <> NULL ) then + '' private? if( symbIsVisPrivate( sym ) ) then return (parent = symbGetCurrentNamespc( )) + '' protected? elseif( symbIsVisProtected( sym ) ) then - return symbIsChildOf( parent, symbGetCurrentNamespc( ) ) + var ns = symbGetCurrentNamespc( ) + + '' is symbol from a base class? + select case ns->typ + case FB_DATATYPE_STRUCT + return ( parent = ns or ns->udt.base = parent ) + case else + '' symbol is from a child namespace? + return symbIsChildOf( parent, ns ) + End Select + end if end if From 5a04256a2fd22a684097a88751f7ef035b2f7e24 Mon Sep 17 00:00:00 2001 From: v1ctor Date: Sat, 26 Mar 2011 01:54:19 +0000 Subject: [PATCH 02/17] changed: inheritance (more WIP) r5465 --- FreeBASIC/src/compiler/parser-decl-struct.bas | 10 ++++------ FreeBASIC/src/compiler/symb-struct.bas | 4 ++-- FreeBASIC/src/compiler/symb.bas | 11 ++++++++++- 3 files changed, 16 insertions(+), 9 deletions(-) diff --git a/FreeBASIC/src/compiler/parser-decl-struct.bas b/FreeBASIC/src/compiler/parser-decl-struct.bas index ac48a8f3fb..b77c403379 100644 --- a/FreeBASIC/src/compiler/parser-decl-struct.bas +++ b/FreeBASIC/src/compiler/parser-decl-struct.bas @@ -728,12 +728,10 @@ private function hTypeAdd _ if( baseDType <> FB_DATATYPE_VOID ) then static as FBARRAYDIM dTB(0 to 0) - if( symbAddField( s, @"base", _ - 0, dTB(), _ - baseDtype, baseSubtype, _ - baseLgt, 0 ) <> NULL ) then - - s->udt.base = baseSubtype + s->udt.base = symbAddField( s, @"base", 0, dTB(), baseDtype, baseSubtype, baseLgt, 0 ) + + if( s->udt.base <> NULL ) then + s->udt.base->attrib or= FB_SYMBATTRIB_VIS_PROTECTED symbNamespaceImportEx( baseSubtype, s ) End If diff --git a/FreeBASIC/src/compiler/symb-struct.bas b/FreeBASIC/src/compiler/symb-struct.bas index e84be21a23..a4f83f4f0a 100644 --- a/FreeBASIC/src/compiler/symb-struct.bas +++ b/FreeBASIC/src/compiler/symb-struct.bas @@ -1033,11 +1033,11 @@ function symbIsUDTBaseOf _ end if do until( s->udt.base = NULL ) - if( s->udt.base = baseSym ) then + if( s->udt.base->subtype = baseSym ) then return TRUE End If - s = s->udt.base + s = s->udt.base->subtype Loop return FALSE diff --git a/FreeBASIC/src/compiler/symb.bas b/FreeBASIC/src/compiler/symb.bas index 3bec9bc283..bf4e99c427 100644 --- a/FreeBASIC/src/compiler/symb.bas +++ b/FreeBASIC/src/compiler/symb.bas @@ -1963,7 +1963,16 @@ function symbCheckAccess _ '' is symbol from a base class? select case ns->typ case FB_DATATYPE_STRUCT - return ( parent = ns or ns->udt.base = parent ) + If( parent = ns ) Then + Return TRUE + End If + + If( ns->udt.base = NULL ) Then + Return FALSE + End If + + Return ns->udt.base->subtype = parent + case else '' symbol is from a child namespace? return symbIsChildOf( parent, ns ) From 8a0942965469ba352cd05dc15809197e21f4b7a3 Mon Sep 17 00:00:00 2001 From: v1ctor Date: Sun, 27 Mar 2011 16:27:47 +0000 Subject: [PATCH 03/17] changed: inheritance (more WIP) r5466 --- FreeBASIC/src/compiler/ast-node-proc.bas | 125 +++++++------ FreeBASIC/src/compiler/error.bas | 7 +- FreeBASIC/src/compiler/inc/error.bi | 3 + FreeBASIC/src/compiler/inc/parser.bi | 1 + FreeBASIC/src/compiler/parser-decl-struct.bas | 4 +- FreeBASIC/src/compiler/parser-expr-atom.bas | 86 ++++++++- .../src/compiler/parser-expr-variable.bas | 9 +- FreeBASIC/src/compiler/parser-proccall.bas | 176 +++++++++++++++++- FreeBASIC/src/compiler/symb.bas | 16 +- 9 files changed, 354 insertions(+), 73 deletions(-) diff --git a/FreeBASIC/src/compiler/ast-node-proc.bas b/FreeBASIC/src/compiler/ast-node-proc.bas index 62c7573cca..899b0373b1 100644 --- a/FreeBASIC/src/compiler/ast-node-proc.bas +++ b/FreeBASIC/src/compiler/ast-node-proc.bas @@ -1075,23 +1075,29 @@ private sub hCallFieldCtors _ do while( fld <> NULL ) if( symbIsField( fld ) ) then - '' part of an union? - if( symbGetIsUnionField( fld ) ) then - fld = hClearUnionFields( this_, fld ) - - '' skip next - continue do - - else - '' not initialized? - if( symbGetTypeIniTree( fld ) = NULL ) then - hCallFieldCtor( this_, fld ) - - '' flush the tree.. + + '' super class 'base' field? skip.. ctor must be called from derived class' ctor + If( fld <> parent->udt.base ) Then + + '' part of an union? + if( symbGetIsUnionField( fld ) ) then + fld = hClearUnionFields( this_, fld ) + + '' skip next + continue do + else - hFlushFieldInitTree( this_, fld ) - end if - end if + '' not initialized? + if( symbGetTypeIniTree( fld ) = NULL ) then + hCallFieldCtor( this_, fld ) + + '' flush the tree.. + else + hFlushFieldInitTree( this_, fld ) + end if + end If + + End If end if fld = fld->next @@ -1136,47 +1142,52 @@ private sub hCallFieldDtors _ if( symbIsField( fld ) ) then - select case symbGetType( fld ) - case FB_DATATYPE_STRING - dim as ASTNODE ptr fldexpr - - fldexpr = astBuildInstPtr( this_, fld ) - - '' not an array? - if( (symbGetArrayDimensions( fld ) = 0) or _ - (symbGetArrayElements( fld ) = 1) ) then - - astAdd( rtlStrDelete( fldexpr ) ) - - '' array.. - else - astAdd( rtlArrayStrErase( fldexpr ) ) - end if - - case FB_DATATYPE_STRUCT - dim as FBSYMBOL ptr subtype - - subtype = symbGetSubtype( fld ) - - '' has a dtor too? - if( symbGetHasDtor( subtype ) ) then - - '' not an array? - if( (symbGetArrayDimensions( fld ) = 0) or _ - (symbGetArrayElements( fld ) = 1) ) then - - '' dtor( this.field ) - astAdd( astBuildDtorCall( subtype, _ - astBuildInstPtr( this_, fld ) ) ) - - '' array.. - else - hCallCtorList( FALSE, this_, fld ) - end if - - end if - - end select + '' super class 'base' field? skip.. dtor must be called from derived class' dtor + If( fld <> parent->udt.base ) Then + + select case symbGetType( fld ) + case FB_DATATYPE_STRING + dim as ASTNODE ptr fldexpr + + fldexpr = astBuildInstPtr( this_, fld ) + + '' not an array? + if( (symbGetArrayDimensions( fld ) = 0) or _ + (symbGetArrayElements( fld ) = 1) ) then + + astAdd( rtlStrDelete( fldexpr ) ) + + '' array.. + else + astAdd( rtlArrayStrErase( fldexpr ) ) + end if + + case FB_DATATYPE_STRUCT + dim as FBSYMBOL ptr subtype + + subtype = symbGetSubtype( fld ) + + '' has a dtor too? + if( symbGetHasDtor( subtype ) ) then + + '' not an array? + if( (symbGetArrayDimensions( fld ) = 0) or _ + (symbGetArrayElements( fld ) = 1) ) then + + '' dtor( this.field ) + astAdd( astBuildDtorCall( subtype, _ + astBuildInstPtr( this_, fld ) ) ) + + '' array.. + else + hCallCtorList( FALSE, this_, fld ) + end if + + end if + + end Select + + End if end if fld = fld->prev diff --git a/FreeBASIC/src/compiler/error.bas b/FreeBASIC/src/compiler/error.bas index 5f8fcae612..81e48f12ae 100644 --- a/FreeBASIC/src/compiler/error.bas +++ b/FreeBASIC/src/compiler/error.bas @@ -230,7 +230,7 @@ end type @"Illegal outside a DESTRUCTOR block", _ @"UDT's with methods must have unique names", _ @"Parent is not a class or UDT", _ - @"Call to another constructor must be the first statement", _ + @"Call to another constructor or a base class constructor must be the first statement", _ @"The constructor or destructor calling convention must be CDECL", _ @"This symbol cannot be undefined", _ @"Either 'RETURN' or 'FUNCTION =' should be used when returning objects with default constructors", _ @@ -310,7 +310,10 @@ end type @"Selected option requires an SSE FPU mode", _ @"Expected relational operator ( =, >, <, <>, <=, >= )", _ @"Unsupported statement in -gen gcc mode", _ - @"TYPE can only extend other TYPE symbols" _ + @"TYPE can only extend other TYPE symbols", _ + @"Illegal outside a CLASS, TYPE or UNION method", _ + @"CLASS, TYPE or UNION not derived", _ + @"CLASS, TYPE or UNION has no constructor" _ } diff --git a/FreeBASIC/src/compiler/inc/error.bi b/FreeBASIC/src/compiler/inc/error.bi index 592b4b6092..d8f091d831 100644 --- a/FreeBASIC/src/compiler/inc/error.bi +++ b/FreeBASIC/src/compiler/inc/error.bi @@ -259,6 +259,9 @@ enum FB_ERRMSG FB_ERRMSG_EXPECTEDRELOP FB_ERRMSG_STMTUNSUPPORTEDINGCC FB_ERRMSG_EXPECTEDCLASSTYPE + FB_ERRMSG_ILLEGALOUTSIDEAMETHOD + FB_ERRMSG_CLASSNOTDERIVED + FB_ERRMSG_CLASSWITHOUTCTOR FB_ERRMSGS end enum diff --git a/FreeBASIC/src/compiler/inc/parser.bi b/FreeBASIC/src/compiler/inc/parser.bi index 73f5f5e0db..0511180f34 100644 --- a/FreeBASIC/src/compiler/inc/parser.bi +++ b/FreeBASIC/src/compiler/inc/parser.bi @@ -773,6 +773,7 @@ declare function cWithVariable _ declare function cImplicitDataMember _ ( _ + byval base_parent as FBSYMBOL ptr, _ byval chain_ as FBSYMCHAIN ptr, _ byval checkarray as integer _ ) as ASTNODE ptr diff --git a/FreeBASIC/src/compiler/parser-decl-struct.bas b/FreeBASIC/src/compiler/parser-decl-struct.bas index b77c403379..47ad5ce5e0 100644 --- a/FreeBASIC/src/compiler/parser-decl-struct.bas +++ b/FreeBASIC/src/compiler/parser-decl-struct.bas @@ -728,11 +728,9 @@ private function hTypeAdd _ if( baseDType <> FB_DATATYPE_VOID ) then static as FBARRAYDIM dTB(0 to 0) - s->udt.base = symbAddField( s, @"base", 0, dTB(), baseDtype, baseSubtype, baseLgt, 0 ) + s->udt.base = symbAddField( s, @"{fb}base", 0, dTB(), baseDtype, baseSubtype, baseLgt, 0 ) if( s->udt.base <> NULL ) then - s->udt.base->attrib or= FB_SYMBATTRIB_VIS_PROTECTED - symbNamespaceImportEx( baseSubtype, s ) End If end if diff --git a/FreeBASIC/src/compiler/parser-expr-atom.bas b/FreeBASIC/src/compiler/parser-expr-atom.bas index 3df0a89d04..d9e53ca363 100644 --- a/FreeBASIC/src/compiler/parser-expr-atom.bas +++ b/FreeBASIC/src/compiler/parser-expr-atom.bas @@ -26,6 +26,13 @@ #include once "inc\parser.bi" #include once "inc\ast.bi" +declare function hBaseMemberAccess _ + ( _ + _ + ) as ASTNODE ptr + + +''::::: function cEqInParentsOnlyExpr _ ( _ _ @@ -282,11 +289,17 @@ private function hFindId _ return cVariableEx( chain_, fbGetCheckArray( ) ) case FB_SYMBCLASS_FIELD - return cImplicitDataMember( chain_, fbGetCheckArray( ) ) + return cImplicitDataMember( base_parent, chain_, fbGetCheckArray( ) ) '' quirk-keyword? case FB_SYMBCLASS_KEYWORD - return cQuirkFunction( sym ) + + '' BASE? + if( lexGetToken() = FB_TK_BASE ) then + return hBaseMemberAccess( ) + else + return cQuirkFunction( sym ) + EndIf case FB_SYMBCLASS_STRUCT, FB_SYMBCLASS_CLASS if( symbGetHasCtor( sym ) ) then @@ -318,6 +331,75 @@ private function hFindId _ end function +''::::: +'' BaseMemberAccess = (BASE '.')+ ID +'' +'' +private function hBaseMemberAccess _ + ( _ + _ + ) as ASTNODE ptr + + var proc = parser.currproc + + '' not inside a method? + if( symbIsMethod( proc ) = FALSE ) then + if( errReport( FB_ERRMSG_ILLEGALOUTSIDEAMETHOD ) = FALSE ) then + return NULL + else + '' error recovery: skip stmt, return + hSkipStmt( ) + return astNewCONSTi( 0 ) + end if + End If + + var parent = symbGetNamespace( proc ) + + '' is class derived? + var base_ = parent->udt.base + + do + if( base_ = NULL ) then + if( errReport( FB_ERRMSG_CLASSNOTDERIVED ) = FALSE ) then + return NULL + else + '' error recovery: skip stmt, return + hSkipStmt( ) + return astNewCONSTi( 0 ) + end if + End If + + '' skip BASE + lexSkipToken( LEXCHECK_NOPERIOD ) + + '' skip '.' + lexSkipToken() + + '' (BASE '.')? + if( lexGetToken() <> FB_TK_BASE ) then + exit do + EndIf + + '' '.' + if( lexGetLookAhead( 1 ) <> CHAR_DOT ) then + if( errReport( FB_ERRMSG_EXPECTEDPERIOD ) = FALSE ) then + return NULL + else + '' error recovery: skip stmt, return + hSkipStmt( ) + return astNewCONSTi( 0 ) + end if + End If + + base_ = symbGetSubtype( base_ )->udt.base + loop + + dim as FBSYMCHAIN chain_ = (base_, NULL, FALSE) + + return hFindId( symbGetSubtype( base_ ), @chain_ ) + +end function + ''::::: ''Atom = Constant | Function | QuirkFunction | Variable | Literal . '' diff --git a/FreeBASIC/src/compiler/parser-expr-variable.bas b/FreeBASIC/src/compiler/parser-expr-variable.bas index 1f98f15286..13d0aa9254 100644 --- a/FreeBASIC/src/compiler/parser-expr-variable.bas +++ b/FreeBASIC/src/compiler/parser-expr-variable.bas @@ -346,7 +346,7 @@ private function hMemberId _ select case as const symbGetClass( sym ) '' const? (enum elmts too) case FB_SYMBCLASS_CONST, FB_SYMBCLASS_ENUM - '' check visibility + '' check visibility if( symbCheckAccess( parent, sym ) = FALSE ) then if( errReport( FB_ERRMSG_ILLEGALMEMBERACCESS ) = FALSE ) then return NULL @@ -1716,6 +1716,7 @@ end function '' function cImplicitDataMember _ ( _ + byval base_parent as FBSYMBOL ptr, _ byval chain_ as FBSYMCHAIN ptr, _ byval check_array as integer _ ) as ASTNODE ptr @@ -1731,10 +1732,14 @@ function cImplicitDataMember _ errReport( FB_ERRMSG_STATICMEMBERHASNOINSTANCEPTR ) return NULL end if + + if( base_parent = NULL ) then + base_parent = symbGetSubtype( this_ ) + End If function = hImpField( this_, _ symbGetFullType( this_ ), _ - symbGetSubtype( this_ ), _ + base_parent, _ check_array ) end function diff --git a/FreeBASIC/src/compiler/parser-proccall.bas b/FreeBASIC/src/compiler/parser-proccall.bas index a08d142a68..8ba4c4cf25 100644 --- a/FreeBASIC/src/compiler/parser-proccall.bas +++ b/FreeBASIC/src/compiler/parser-proccall.bas @@ -32,6 +32,16 @@ declare function hCtorChain _ _ ) as integer +declare function hBaseCtorCall _ + ( _ + _ + ) as integer + +declare function hBaseMemberAccess _ + ( _ + _ + ) as integer + declare function hForwardCall _ ( _ _ @@ -744,7 +754,7 @@ private function hAssignOrCall _ exit function end if else - expr = cImplicitDataMember( chain_, TRUE ) + expr = cImplicitDataMember( base_parent, chain_, TRUE ) if( expr = NULL ) then exit function end if @@ -942,6 +952,16 @@ function cProcCallOrAssign _ return hCtorChain( ) + '' BASE? + case FB_TK_BASE + + '' accessing a base member? + if( lexGetLookAhead( 1 ) = CHAR_DOT ) then + return hBaseMemberAccess( ) + else + return hBaseCtorCall( ) + End If + '' CALL? case FB_TK_CALL @@ -1030,7 +1050,13 @@ private function hCtorChain _ ctor_head = symbGetCompCtorHead( parent ) if( ctor_head = NULL ) then - return FALSE + if( errReport( FB_ERRMSG_CLASSWITHOUTCTOR ) = FALSE ) then + return FALSE + else + '' error recovery: skip stmt, return + hSkipStmt( ) + return TRUE + end if end if '' this must be set before doing any AST call, or the ctor @@ -1050,6 +1076,152 @@ private function hCtorChain _ end function +''::::: +private function hBaseCtorCall _ + ( _ + _ + ) as integer + + dim as FBSYMBOL ptr proc = any, parent = any, ctor_head = any + + proc = parser.currproc + + '' not inside a ctor? + if( symbIsConstructor( proc ) = FALSE ) then + if( errReport( FB_ERRMSG_ILLEGALOUTSIDEACTOR ) = FALSE ) then + return FALSE + else + '' error recovery: skip stmt, return + hSkipStmt( ) + return TRUE + end if + end if + + parent = symbGetNamespace( proc ) + + '' is class derived? + var base_ = parent->udt.base + if( base_ = NULL ) then + if( errReport( FB_ERRMSG_CLASSNOTDERIVED ) = FALSE ) then + return FALSE + else + '' error recovery: skip stmt, return + hSkipStmt( ) + return TRUE + end if + End If + + '' not the first stmt? + if( symbGetIsCtorInited( proc ) ) then + if( errReport( FB_ERRMSG_CALLTOCTORMUSTBETHEFIRSTSTMT ) = FALSE ) then + return FALSE + else + '' error recovery: skip stmt, return + hSkipStmt( ) + return TRUE + end if + end if + + ctor_head = symbGetCompCtorHead( symbGetSubtype( base_ ) ) + if( ctor_head = NULL ) then + if( errReport( FB_ERRMSG_CLASSWITHOUTCTOR ) = FALSE ) then + return FALSE + else + '' error recovery: skip stmt, return + hSkipStmt( ) + return TRUE + end if + end if + + '' BASE + lexSkipToken( ) + + '' this must be set before doing any AST call, or the ctor + '' initialization would be trigged + symbSetIsCtorInited( proc ) + + var this_ = symbGetProcHeadParam( proc ) + if( this_ = NULL ) then + return FALSE + end if + + var this_expr = astBuildInstPtr( symbGetParamVar( this_ ), base_ ) + + cProcCall( NULL, ctor_head, NULL, this_expr ) + + function = (errGetLast( ) = FB_ERRMSG_OK) + +end function + +''::::: +'' BaseMemberAccess = (BASE '.')+ ID +'' +'' +private function hBaseMemberAccess _ + ( _ + _ + ) as integer + + var proc = parser.currproc + + '' not inside a method? + if( symbIsMethod( proc ) = FALSE ) then + if( errReport( FB_ERRMSG_ILLEGALOUTSIDEAMETHOD ) = FALSE ) then + return FALSE + else + '' error recovery: skip stmt, return + hSkipStmt( ) + return TRUE + end if + End If + + var parent = symbGetNamespace( proc ) + + '' is class derived? + var base_ = parent->udt.base + + do + if( base_ = NULL ) then + if( errReport( FB_ERRMSG_CLASSNOTDERIVED ) = FALSE ) then + return FALSE + else + '' error recovery: skip stmt, return + hSkipStmt( ) + return TRUE + end if + End If + + '' skip BASE + lexSkipToken( LEXCHECK_NOPERIOD ) + + '' skip '.' + lexSkipToken() + + '' (BASE '.')? + if( lexGetToken() <> FB_TK_BASE ) then + exit do + EndIf + + '' '.' + if( lexGetLookAhead( 1 ) <> CHAR_DOT ) then + if( errReport( FB_ERRMSG_EXPECTEDPERIOD ) = FALSE ) then + return FALSE + else + '' error recovery: skip stmt, return + hSkipStmt( ) + return TRUE + end if + End If + + base_ = symbGetSubtype( base_ )->udt.base + loop + + dim as FBSYMCHAIN chain_ = (base_, NULL, FALSE) + + return hAssignOrCall( symbGetSubType( base_ ), @chain_, FALSE ) + +end function + ''::::: function hForwardCall _ ( _ diff --git a/FreeBASIC/src/compiler/symb.bas b/FreeBASIC/src/compiler/symb.bas index bf4e99c427..299a7b50f5 100644 --- a/FreeBASIC/src/compiler/symb.bas +++ b/FreeBASIC/src/compiler/symb.bas @@ -1967,11 +1967,17 @@ function symbCheckAccess _ Return TRUE End If - If( ns->udt.base = NULL ) Then - Return FALSE - End If - - Return ns->udt.base->subtype = parent + '' try until the last base class + var base_ = ns->udt.base + do while( base_ <> NULL ) + if( symbGetSubType( base_ ) = parent ) then + return TRUE + End If + + base_ = symbGetSubtype( base_ )->udt.base + loop + + return FALSE case else '' symbol is from a child namespace? From 5cd1833281f254191403ba27c532413c0f9cfcd6 Mon Sep 17 00:00:00 2001 From: v1ctor Date: Sun, 27 Mar 2011 17:46:03 +0000 Subject: [PATCH 04/17] changed: inheritance (more WIP) r5467 --- FreeBASIC/src/compiler/ast-node-proc.bas | 140 ++++++++++++++++------- 1 file changed, 97 insertions(+), 43 deletions(-) diff --git a/FreeBASIC/src/compiler/ast-node-proc.bas b/FreeBASIC/src/compiler/ast-node-proc.bas index 899b0373b1..c21c5afbb8 100644 --- a/FreeBASIC/src/compiler/ast-node-proc.bas +++ b/FreeBASIC/src/compiler/ast-node-proc.bas @@ -1105,6 +1105,29 @@ private sub hCallFieldCtors _ end sub +''::::: +private sub hCallBaseCtors _ + ( _ + byval parent as FBSYMBOL ptr, _ + byval proc as FBSYMBOL ptr _ + ) + + if( parent->udt.base = NULL ) then + exit sub + End If + + var ctor = symbGetCompDefCtor( symbGetSubtype( parent->udt.base ) ) + + if( ctor = NULL ) then + exit sub + End If + + var this_ = symbGetParamVar( symbGetProcHeadParam( proc ) ) + + hCallFieldCtor( this_, parent->udt.base ) + +End Sub + ''::::: private sub hCallCtors _ ( _ @@ -1116,13 +1139,61 @@ private sub hCallCtors _ parent = symbGetNamespace( proc ) '' 1st) base ctors - '' ... + hCallBaseCtors( parent, proc ) '' 2nd) field ctors hCallFieldCtors( parent, proc ) end sub +''::::: +private sub hCallFieldDtor _ + ( _ + byval this_ as FBSYMBOL ptr, _ + byval fld as FBSYMBOL ptr _ + ) + + select case symbGetType( fld ) + case FB_DATATYPE_STRING + + var fldexpr = astBuildInstPtr( this_, fld ) + + '' not an array? + if( (symbGetArrayDimensions( fld ) = 0) or _ + (symbGetArrayElements( fld ) = 1) ) then + + astAdd( rtlStrDelete( fldexpr ) ) + + '' array.. + else + astAdd( rtlArrayStrErase( fldexpr ) ) + end if + + case FB_DATATYPE_STRUCT + var subtype = symbGetSubtype( fld ) + + '' has a dtor too? + if( symbGetHasDtor( subtype ) ) then + + '' not an array? + if( (symbGetArrayDimensions( fld ) = 0) or _ + (symbGetArrayElements( fld ) = 1) ) then + + '' dtor( this.field ) + astAdd( astBuildDtorCall( subtype, _ + astBuildInstPtr( this_, fld ) ) ) + + '' array.. + else + hCallCtorList( FALSE, this_, fld ) + end if + + end if + + end Select + +End Sub + ''::::: private sub hCallFieldDtors _ ( _ @@ -1145,47 +1216,7 @@ private sub hCallFieldDtors _ '' super class 'base' field? skip.. dtor must be called from derived class' dtor If( fld <> parent->udt.base ) Then - select case symbGetType( fld ) - case FB_DATATYPE_STRING - dim as ASTNODE ptr fldexpr - - fldexpr = astBuildInstPtr( this_, fld ) - - '' not an array? - if( (symbGetArrayDimensions( fld ) = 0) or _ - (symbGetArrayElements( fld ) = 1) ) then - - astAdd( rtlStrDelete( fldexpr ) ) - - '' array.. - else - astAdd( rtlArrayStrErase( fldexpr ) ) - end if - - case FB_DATATYPE_STRUCT - dim as FBSYMBOL ptr subtype - - subtype = symbGetSubtype( fld ) - - '' has a dtor too? - if( symbGetHasDtor( subtype ) ) then - - '' not an array? - if( (symbGetArrayDimensions( fld ) = 0) or _ - (symbGetArrayElements( fld ) = 1) ) then - - '' dtor( this.field ) - astAdd( astBuildDtorCall( subtype, _ - astBuildInstPtr( this_, fld ) ) ) - - '' array.. - else - hCallCtorList( FALSE, this_, fld ) - end if - - end if - - end Select + hCallFieldDtor( this_, fld ) End if end if @@ -1195,6 +1226,29 @@ private sub hCallFieldDtors _ end sub +''::::: +private sub hCallBaseDtors _ + ( _ + byval parent as FBSYMBOL ptr, _ + byval proc as FBSYMBOL ptr _ + ) + + if( parent->udt.base = NULL ) then + exit sub + End If + + var dtor = symbGetCompDtor( symbGetSubtype( parent->udt.base ) ) + + if( dtor = NULL ) then + exit sub + End If + + var this_ = symbGetParamVar( symbGetProcHeadParam( proc ) ) + + hCallFieldDtor( this_, parent->udt.base ) + +end sub + ''::::: private sub hCallDtors _ ( _ @@ -1209,7 +1263,7 @@ private sub hCallDtors _ hCallFieldDtors( parent, proc ) '' 2nd) base dtors - '' ... + hCallBaseDtors( parent, proc ) end sub From 30ba2724d76d341aae89f8eab911a2593241d708 Mon Sep 17 00:00:00 2001 From: v1ctor Date: Mon, 28 Mar 2011 00:49:52 +0000 Subject: [PATCH 05/17] changed: inheritance (more WIP) r5468 --- FreeBASIC/src/compiler/ir-hlc.bas | 28 +++++++++++++------ FreeBASIC/src/compiler/parser-decl-struct.bas | 2 +- .../src/compiler/parser-expr-function.bas | 7 +++++ FreeBASIC/src/compiler/parser-proccall.bas | 6 ++++ 4 files changed, 34 insertions(+), 9 deletions(-) diff --git a/FreeBASIC/src/compiler/ir-hlc.bas b/FreeBASIC/src/compiler/ir-hlc.bas index c640b9a3e3..482ffc5446 100644 --- a/FreeBASIC/src/compiler/ir-hlc.bas +++ b/FreeBASIC/src/compiler/ir-hlc.bas @@ -1898,19 +1898,29 @@ private sub hEmitVregExpr _ ( _ byval vr as IRVREG ptr, _ byref expr as string, _ - byval is_call as integer = FALSE _ + byval is_call as integer = FALSE, _ + byval add_cast as integer = TRUE _ ) if( irIsREG( vr ) ) then var ln = "" - var typ = *hDtypeToStr( vr->dtype, vr->subtype ) var id = hVregToStr( vr ) - - if( is_call ) then - ln = typ & " " & id & " = (" & typ & ")(" & expr & ");" + + if( add_cast = FALSE ) then + if( is_call ) then + errReportEx( FB_ERRMSG_INTERNAL, __FUNCTION__ ) + else + ln = "#define " & id & " ((" & expr & "))" + end if else - ln = "#define " & id & " ((" & typ & ")(" & expr & "))" - end if + var typ = *hDtypeToStr( vr->dtype, vr->subtype ) + + if( is_call ) then + ln = typ & " " & id & " = (" & typ & ")(" & expr & ");" + else + ln = "#define " & id & " ((" & typ & ")(" & expr & "))" + end if + End If hWriteLine( ln, FALSE, TRUE ) else @@ -2142,7 +2152,9 @@ private sub _emitConvert _ hEmitUDT( to_subtype, typeIsPtr( to_dtype ) ) - hEmitVregExpr( v1, hVregToStr( v2 ) ) + var add_cast = typeGet( to_dtype ) <> FB_DATATYPE_STRUCT + + hEmitVregExpr( v1, hVregToStr( v2, add_cast ), FALSE, add_cast ) end sub diff --git a/FreeBASIC/src/compiler/parser-decl-struct.bas b/FreeBASIC/src/compiler/parser-decl-struct.bas index 47ad5ce5e0..d1a5de6bd9 100644 --- a/FreeBASIC/src/compiler/parser-decl-struct.bas +++ b/FreeBASIC/src/compiler/parser-decl-struct.bas @@ -728,7 +728,7 @@ private function hTypeAdd _ if( baseDType <> FB_DATATYPE_VOID ) then static as FBARRAYDIM dTB(0 to 0) - s->udt.base = symbAddField( s, @"{fb}base", 0, dTB(), baseDtype, baseSubtype, baseLgt, 0 ) + s->udt.base = symbAddField( s, hMakeTmpStrNL( ), 0, dTB(), baseDtype, baseSubtype, baseLgt, 0 ) if( s->udt.base <> NULL ) then symbNamespaceImportEx( baseSubtype, s ) diff --git a/FreeBASIC/src/compiler/parser-expr-function.bas b/FreeBASIC/src/compiler/parser-expr-function.bas index 137614b857..725434d38f 100644 --- a/FreeBASIC/src/compiler/parser-expr-function.bas +++ b/FreeBASIC/src/compiler/parser-expr-function.bas @@ -63,7 +63,14 @@ function cFunctionCall _ '' method call? if( thisexpr <> NULL ) then dim as FB_CALL_ARG ptr arg = symbAllocOvlCallArg( @parser.ovlarglist, @arg_list, FALSE ) + + var instParam = symbGetProcHeadParam( sym ) + if( astGetSubtype( thisexpr ) <> symbGetSubtype( instParam ) ) then + thisexpr = astNewCONV( symbGetType( instParam ), symbGetSubType( instParam ), thisexpr ) + EndIf + arg->expr = thisexpr + arg->mode = hGetInstPtrMode( thisexpr ) options or= FB_PARSEROPT_HASINSTPTR end if diff --git a/FreeBASIC/src/compiler/parser-proccall.bas b/FreeBASIC/src/compiler/parser-proccall.bas index 8ba4c4cf25..a0b8ab6a13 100644 --- a/FreeBASIC/src/compiler/parser-proccall.bas +++ b/FreeBASIC/src/compiler/parser-proccall.bas @@ -203,6 +203,12 @@ function cProcCall _ '' method call? if( thisexpr <> NULL ) then dim as FB_CALL_ARG ptr arg = symbAllocOvlCallArg( @parser.ovlarglist, @arg_list, FALSE ) + + var instParam = symbGetProcHeadParam( sym ) + if( astGetSubtype( thisexpr ) <> symbGetSubtype( instParam ) ) then + thisexpr = astNewCONV( symbGetType( instParam ), symbGetSubType( instParam ), thisexpr ) + EndIf + arg->expr = thisexpr arg->mode = hGetInstPtrMode( thisexpr ) options or= FB_PARSEROPT_HASINSTPTR From e91e51717f36002a44088933610e8d62e234f8f8 Mon Sep 17 00:00:00 2001 From: v1ctor Date: Tue, 29 Mar 2011 21:44:18 +0000 Subject: [PATCH 06/17] changed: inheritance (more WIP) r5469 --- FreeBASIC/src/compiler/ast-misc.bas | 2 +- FreeBASIC/src/compiler/ast-node-arg.bas | 28 ++++++++++++++-------- FreeBASIC/src/compiler/ast-node-assign.bas | 17 +++++++++++-- FreeBASIC/src/compiler/ast-node-conv.bas | 4 ++-- FreeBASIC/src/compiler/inc/symb.bi | 4 ++-- FreeBASIC/src/compiler/symb-proc.bas | 11 +++++++++ FreeBASIC/src/compiler/symb-struct.bas | 14 ++++++----- FreeBASIC/src/compiler/symb.bas | 8 +++++-- 8 files changed, 63 insertions(+), 25 deletions(-) diff --git a/FreeBASIC/src/compiler/ast-misc.bas b/FreeBASIC/src/compiler/ast-misc.bas index b5cc41c947..32b11155c1 100644 --- a/FreeBASIC/src/compiler/ast-misc.bas +++ b/FreeBASIC/src/compiler/ast-misc.bas @@ -858,7 +858,7 @@ function astPtrCheck _ end if '' check sub types - function = symbIsEqual( psubtype, astGetSubType( expr ) ) + function = symbIsEqual( astGetSubType( expr ), psubtype ) end function diff --git a/FreeBASIC/src/compiler/ast-node-arg.bas b/FreeBASIC/src/compiler/ast-node-arg.bas index 0ce42b58c6..512c19d389 100644 --- a/FreeBASIC/src/compiler/ast-node-arg.bas +++ b/FreeBASIC/src/compiler/ast-node-arg.bas @@ -807,21 +807,17 @@ private function hCheckUDTParam _ '' check for invalid UDT's (different subtypes) if( symbGetSubtype( param ) <> arg->subtype ) then - if( hImplicitCtor( parent, param, n ) = FALSE ) then - - if( symbIsUDTBaseOf( arg->subtype, symbGetSubtype( param ) ) = FALSE ) then - hParamError( parent ) - return FALSE - else + '' 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? n->l = astNewCONV( symbGetType( param ), symbGetSubtype( param ), arg ) if( n->l = NULL ) then hParamError( parent ) return FALSE End If End If - - else - return TRUE end if end if @@ -1065,7 +1061,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 diff --git a/FreeBASIC/src/compiler/ast-node-assign.bas b/FreeBASIC/src/compiler/ast-node-assign.bas index 31be84980e..75a0b549f1 100644 --- a/FreeBASIC/src/compiler/ast-node-assign.bas +++ b/FreeBASIC/src/compiler/ast-node-assign.bas @@ -105,7 +105,8 @@ private function hCheckUDTOps _ '' different subtypes? if( l->subtype <> r->subtype ) then - exit function + '' check if lhs is a base type of rhs + return symbGetUDTBaseLevel( r->subtype, l->subtype ) > 0 end if function = TRUE @@ -248,8 +249,20 @@ private function 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 + if( errReport( FB_ERRMSG_ILLEGALASSIGNMENT, TRUE ) = FALSE ) then + exit function + else + return TRUE + end if + else + errReportWarn( FB_WARNINGMSG_SUSPICIOUSPTRASSIGN ) + end if + end if end if + '' r-side expr is a ptr? elseif( typeIsPtr( rdtype ) ) then errReportWarn( FB_WARNINGMSG_IMPLICITCONVERSION ) diff --git a/FreeBASIC/src/compiler/ast-node-conv.bas b/FreeBASIC/src/compiler/ast-node-conv.bas index bd1230df7c..c923d01afb 100644 --- a/FreeBASIC/src/compiler/ast-node-conv.bas +++ b/FreeBASIC/src/compiler/ast-node-conv.bas @@ -342,7 +342,7 @@ function astCheckCONV _ '' UDT? only downcasting supported by now if( typeGet( to_dtype ) = FB_DATATYPE_STRUCT ) then - return symbIsUDTBaseOf( l->subtype, to_subtype ) + return symbGetUDTBaseLevel( l->subtype, to_subtype ) > 0 end if ldtype = astGetFullType( l ) @@ -426,7 +426,7 @@ function astNewCONV _ exit function case FB_DATATYPE_STRUCT ', FB_DATATYPE_CLASS - if( symbIsUDTBaseOf( l->subtype, to_subtype ) = FALSE ) then + if( symbGetUDTBaseLevel( l->subtype, to_subtype ) = 0 ) then exit function End If diff --git a/FreeBASIC/src/compiler/inc/symb.bi b/FreeBASIC/src/compiler/inc/symb.bi index 5028809dfd..e97eee9d37 100644 --- a/FreeBASIC/src/compiler/inc/symb.bi +++ b/FreeBASIC/src/compiler/inc/symb.bi @@ -1910,11 +1910,11 @@ declare function symbIsUDTReturnedInRegs _ byval s as FBSYMBOL ptr _ ) as integer -declare function symbIsUDTBaseOf _ +declare function symbGetUDTBaseLevel _ ( _ byval s as FBSYMBOL ptr, _ byval baseSym as FBSYMBOL ptr _ - ) as Integer + ) as integer diff --git a/FreeBASIC/src/compiler/symb-proc.bas b/FreeBASIC/src/compiler/symb-proc.bas index 3e8bc26ffa..9044d5323e 100644 --- a/FreeBASIC/src/compiler/symb-proc.bas +++ b/FreeBASIC/src/compiler/symb-proc.bas @@ -1811,6 +1811,17 @@ private function hCheckOvlParam _ '' same subtype? full match.. if( param_subtype = arg_subtype ) then return FB_OVLPROC_FULLMATCH + else + '' is param type a base type of the argument type? + if( param_subtype <> NULL ) then + select case symbGetType( param_subtype ) + case FB_DATATYPE_STRUCT '' , FB_DATATYPE_CLASS + var level = symbGetUDTBaseLevel( arg_subtype, param_subtype ) + if( level > 0 ) then + return FB_OVLPROC_FULLMATCH - level + End If + End Select + end if end if elseif( typeGetConstMask( param_dtype ) ) then diff --git a/FreeBASIC/src/compiler/symb-struct.bas b/FreeBASIC/src/compiler/symb-struct.bas index a4f83f4f0a..0935a18891 100644 --- a/FreeBASIC/src/compiler/symb-struct.bas +++ b/FreeBASIC/src/compiler/symb-struct.bas @@ -1022,24 +1022,26 @@ function symbIsUDTReturnedInRegs _ end function ''::::: -function symbIsUDTBaseOf _ +function symbGetUDTBaseLevel _ ( _ byval s as FBSYMBOL ptr, _ byval baseSym as FBSYMBOL ptr _ - ) as Integer + ) as integer if( s = NULL or baseSym = NULL ) then - return FALSE + return 0 end if + var level = 1 do until( s->udt.base = NULL ) if( s->udt.base->subtype = baseSym ) then - return TRUE + return level End If - s = s->udt.base->subtype + s = s->udt.base->subtype + level += 1 Loop - return FALSE + return 0 End Function diff --git a/FreeBASIC/src/compiler/symb.bas b/FreeBASIC/src/compiler/symb.bas index 299a7b50f5..1f6fb19322 100644 --- a/FreeBASIC/src/compiler/symb.bas +++ b/FreeBASIC/src/compiler/symb.bas @@ -1674,8 +1674,12 @@ function symbIsEqual _ end if select case sym1->class - '' UDT or enum? - case FB_SYMBCLASS_STRUCT, FB_SYMBCLASS_ENUM + '' UDT? + case FB_SYMBCLASS_STRUCT '', FB_SYMBCLASS_CLASS + return symbGetUDTBaseLevel( sym1, sym2 ) > 0 + + '' enum? + case FB_SYMBCLASS_ENUM '' no check, they are pointing to different symbols exit function From f895ac12f78db2c93c58982e078341bd86bc9e20 Mon Sep 17 00:00:00 2001 From: v1ctor Date: Wed, 30 Mar 2011 17:45:44 +0000 Subject: [PATCH 07/17] changed: inheritance (more WIP) r5471 --- FreeBASIC/src/compiler/ast-node-arg.bas | 10 ++++++++-- FreeBASIC/src/compiler/ast-node-assign.bas | 18 ++++++++++++----- FreeBASIC/src/compiler/ast-node-conv.bas | 6 ++++++ FreeBASIC/src/compiler/inc/symb.bi | 5 +++++ FreeBASIC/src/compiler/symb-struct.bas | 23 ++++++++++++++++++++++ 5 files changed, 55 insertions(+), 7 deletions(-) diff --git a/FreeBASIC/src/compiler/ast-node-arg.bas b/FreeBASIC/src/compiler/ast-node-arg.bas index 512c19d389..3752adeea3 100644 --- a/FreeBASIC/src/compiler/ast-node-arg.bas +++ b/FreeBASIC/src/compiler/ast-node-arg.bas @@ -812,12 +812,18 @@ private function hCheckUDTParam _ '' no ctor in the param's type? if( hImplicitCtor( parent, param, n ) = FALSE ) then '' no cast operator? - n->l = astNewCONV( symbGetType( param ), symbGetSubtype( param ), arg ) - if( n->l = NULL ) then + arg = astNewCONV( symbGetType( param ), symbGetSubtype( param ), arg ) + if( arg = NULL ) then hParamError( parent ) return FALSE End If + n->l = arg End If + + '' cast to the base type + else + arg = astNewCONV( symbGetType( param ), symbGetSubtype( param ), arg ) + n->l = arg end if end if diff --git a/FreeBASIC/src/compiler/ast-node-assign.bas b/FreeBASIC/src/compiler/ast-node-assign.bas index 75a0b549f1..1a0019622a 100644 --- a/FreeBASIC/src/compiler/ast-node-assign.bas +++ b/FreeBASIC/src/compiler/ast-node-assign.bas @@ -80,8 +80,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 @@ -106,7 +107,14 @@ private function hCheckUDTOps _ '' different subtypes? if( l->subtype <> r->subtype ) then '' check if lhs is a base type of rhs - return symbGetUDTBaseLevel( r->subtype, l->subtype ) > 0 + 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 @@ -309,7 +317,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 @@ -523,7 +531,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 diff --git a/FreeBASIC/src/compiler/ast-node-conv.bas b/FreeBASIC/src/compiler/ast-node-conv.bas index c923d01afb..9ebcfdcf5d 100644 --- a/FreeBASIC/src/compiler/ast-node-conv.bas +++ b/FreeBASIC/src/compiler/ast-node-conv.bas @@ -518,6 +518,12 @@ 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 diff --git a/FreeBASIC/src/compiler/inc/symb.bi b/FreeBASIC/src/compiler/inc/symb.bi index e97eee9d37..45be66053c 100644 --- a/FreeBASIC/src/compiler/inc/symb.bi +++ b/FreeBASIC/src/compiler/inc/symb.bi @@ -1916,6 +1916,11 @@ declare function symbGetUDTBaseLevel _ byval baseSym as FBSYMBOL ptr _ ) as integer +declare function symbGetUDTBaseSymbol _ + ( _ + byval s as FBSYMBOL ptr, _ + byval baseSym as FBSYMBOL ptr _ + ) as FBSYMBOL ptr '' diff --git a/FreeBASIC/src/compiler/symb-struct.bas b/FreeBASIC/src/compiler/symb-struct.bas index 0935a18891..e3e5c54d5d 100644 --- a/FreeBASIC/src/compiler/symb-struct.bas +++ b/FreeBASIC/src/compiler/symb-struct.bas @@ -1045,3 +1045,26 @@ function symbGetUDTBaseLevel _ return 0 End Function + +''::::: +function symbGetUDTBaseSymbol _ + ( _ + byval s as FBSYMBOL ptr, _ + byval baseSym as FBSYMBOL ptr _ + ) as FBSYMBOL ptr + + if( s = NULL or baseSym = NULL ) then + return NULL + end if + + do until( s->udt.base = NULL ) + if( s->udt.base->subtype = baseSym ) then + return s->udt.base + End If + + s = s->udt.base->subtype + Loop + + return NULL + +End Function From 6670ae7ff2268d2dd53cb4263b0e6678fb325af9 Mon Sep 17 00:00:00 2001 From: v1ctor Date: Thu, 31 Mar 2011 20:04:55 +0000 Subject: [PATCH 08/17] changed: inheritance (more WIP) r5472 --- FreeBASIC/src/compiler/TODO.txt | 158 +++++++++++++++++++---- FreeBASIC/src/compiler/ast-node-conv.bas | 45 ++++++- 2 files changed, 178 insertions(+), 25 deletions(-) diff --git a/FreeBASIC/src/compiler/TODO.txt b/FreeBASIC/src/compiler/TODO.txt index 6551763d9c..daebbdbc87 100644 --- a/FreeBASIC/src/compiler/TODO.txt +++ b/FreeBASIC/src/compiler/TODO.txt @@ -145,19 +145,14 @@ [ ] without ON ERROR, all stmts returning rt errors should be allowed to be used as functions too -[ ] data/function members: - - add virtual (functions only) - - the vtable must be compatible with G++ 3.x (ie: compatible with - COM interfaces in Windows) - [ ] ParamArray, but with this syntax: foo(...) as bar - array must be built at compile-time and destroyed after the call - take care with objects.. [ ] PP: - - add #pragma cmdline="-foo bar -baz" - - painful to add - - don't allow it if any line was parsed already + [ ] add #pragma cmdline="-foo bar -baz" + - painful to add + - don't allow it if any line was parsed already - [macro expansion: won't work for inner macros - support default arguments? @@ -264,17 +259,136 @@ [ ] classes - *MUST* follow the GCC 3.x ABI to make it easier to reuse C++ libs compiled by GCC - Java/Php5-ish syntax: CLASS INTERFACE EXTENDS IMPLEMENTS THROWS ABSTRACT - - must support forward references for any kind of symbol, so classes can't be stored - directly to AST - - how to deal with "foo(expr)"? it could be an array or a function call.. - - keeping everything in a parser/token tree will allow templates to be added later - - class shouldn't be emitted unless referenced - - function bodies defined outside classes follow the private/public proc rules - - single inheritance, plus interfaces - - exceptions - with stack unwind support - - pure virtual methods - - down casting - - some support for RTTI - - - + [x] single inheritance (EXTENDS) + [ ] abstract classes and methods + [ ] interfaces (INTERFACE, IMPLEMENTS (or reuse EXTENDS?)) + [ ] pure virtual methods + [ ] some support for RTTI + [ ] base IS some_derived + [ ] down casting + [ ] static (base to derived) + [ ] dynamic (polymorphic) + [ ] exceptions - with stack unwind support + + +--------------------------------------------------------------------------------- + +G++ 4.x RTTI and VT formats: + +- all structs are emited with: + .globl, .section + .rdata$[struct name],"dr" + .linkonce same_size + + struct RTTI { + void *stdlib_virtual_table; -- __ZTVN10__cxxabiv117__class_type_infoE+8 if it's a base class; __ZTVN10__cxxabiv120__si_class_type_infoE+8 otherwise + char *mangled_class_name; + RTTI *base_class_RTTI; + }; + + struct VT[mangled class name] { + void *null_pointer; + RTTI *rtti; + ... virtual methods function pointers in the order they were found (including methods in the base classes first) ... + }; + +- every class with virtual methods will have a hidden pointer to the VT, that is initialized by the constructor: + + struct or class SomeBaseClass { + + VT[mangled class name] *vtp; + + SomeBaseClass() + { + vtp = __ZTV13SomeBaseClass+8; -- hidden assignment, +8 to skip the two pointers at the beginning + } + + virtual void PrintMe(int i) + { + }; + }; + +- example: + + struct VT13SomeBaseClass + { + void *null_pointer; + RTTI *rtti; + void (PrintMe *)(int i); + }; + + class SomeBaseClass + { + VT13SomeBaseClass *vtp; + + SomeBaseClass() + { + vtp = __ZTV13SomeBaseClass+8; + } + + virtual void PrintMe(int i) + { + }; + }; + + RTTI __ZTI13SomeBaseClass = + { + __ZTVN10__cxxabiv117__class_type_infoE+8, + "13SomeBaseClass", + NULL + }; + + VT13SomeBaseClass __ZTV13SomeBaseClass = + { + NULL, + __ZTI13SomeBaseClass, + 13SomeBaseClass7PrintMei + }; + + struct VT12SomeExtClass { + void *null_pointer; + RTTI *rtti; + void (PrintMe *)(int i); + void (OnlyInExt *)(); + }; + + class SomeExtClass : SomeBaseClass + { + SomeExtClass() + { + SomeBaseClass(); + vtp = (void *)__ZTV12SomeExtClass+8; + } + + virtual void PrintMe(int i) + { + }; + + virtual void OnlyInExt() + { + }; + }; + + RTTI __ZTI12SomeExtClass = + { + __ZTVN10__cxxabiv120__class_type_infoE+8, + "12SomeExtClass", + NULL + }; + + VT12SomeExtClass __ZTV12SomeExtClass = + { + NULL, + __ZTI12SomeExtClass, + 12SomeExtClass7PrintMei, + 9OnlyInExtv + }; + + int main() + { + SomeBaseClass *sbc = new SomeExtClass(); + + sbc->PrintMe( 1234 ); ==> sbc->vtp->PrintMe( 1234 ) + } + + \ No newline at end of file diff --git a/FreeBASIC/src/compiler/ast-node-conv.bas b/FreeBASIC/src/compiler/ast-node-conv.bas index 9ebcfdcf5d..6a9211ba46 100644 --- a/FreeBASIC/src/compiler/ast-node-conv.bas +++ b/FreeBASIC/src/compiler/ast-node-conv.bas @@ -282,6 +282,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 @@ -322,8 +323,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 @@ -340,7 +379,7 @@ function astCheckCONV _ function = FALSE - '' UDT? only downcasting supported by now + '' UDT? only upcasting supported by now if( typeGet( to_dtype ) = FB_DATATYPE_STRUCT ) then return symbGetUDTBaseLevel( l->subtype, to_subtype ) > 0 end if @@ -353,7 +392,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 @@ -451,7 +490,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 From 7e245dd43345623fdb937140227c857e3fd80b13 Mon Sep 17 00:00:00 2001 From: v1ctor Date: Sat, 2 Apr 2011 21:04:23 +0000 Subject: [PATCH 09/17] changed: inheritance (more WIP) r5473 --- FreeBASIC/src/compiler/TODO.txt | 10 +- FreeBASIC/src/compiler/inc/symb.bi | 30 ++- FreeBASIC/src/compiler/ir-hlc.bas | 6 +- FreeBASIC/src/compiler/parser-decl-struct.bas | 31 +-- FreeBASIC/src/compiler/symb-comp.bas | 193 +++++++++++++++++- FreeBASIC/src/compiler/symb-struct.bas | 44 +++- FreeBASIC/src/compiler/symb.bas | 11 + 7 files changed, 275 insertions(+), 50 deletions(-) diff --git a/FreeBASIC/src/compiler/TODO.txt b/FreeBASIC/src/compiler/TODO.txt index daebbdbc87..9905021e42 100644 --- a/FreeBASIC/src/compiler/TODO.txt +++ b/FreeBASIC/src/compiler/TODO.txt @@ -267,17 +267,19 @@ [ ] base IS some_derived [ ] down casting [ ] static (base to derived) - [ ] dynamic (polymorphic) + [ ] dynamic (polymorphic) [ ] exceptions - with stack unwind support --------------------------------------------------------------------------------- -G++ 4.x RTTI and VT formats: +G++ 4.x RTTI and VT formats in Win32: + +- dynamic_cast(ptr) is converted to: ptr = (ptr != NULL? __dynamic_cast(void *ptr, RTTI *fromType, RTTI *toType, void *nullPtr): NULL); - all structs are emited with: - .globl, .section - .rdata$[struct name],"dr" + .globl [struct name] + .section rdata$[struct name],"dr" .linkonce same_size struct RTTI { diff --git a/FreeBASIC/src/compiler/inc/symb.bi b/FreeBASIC/src/compiler/inc/symb.bi index 45be66053c..282b5b2f10 100644 --- a/FreeBASIC/src/compiler/inc/symb.bi +++ b/FreeBASIC/src/compiler/inc/symb.bi @@ -121,7 +121,7 @@ enum FB_SYMBSTATS FB_SYMBSTATS_HASCTOR = &h00080000 FB_SYMBSTATS_HASCOPYCTOR = &h00100000 FB_SYMBSTATS_HASDTOR = &h00200000 - FB_SYMBSTATS_HASVIRTUAL = &h00400000 + FB_SYMBSTATS_HASRTTI = &h00400000 FB_SYMBSTATS_CANTUNDEF = &h00800000 FB_SYMBSTATS_UNIONFIELD = &h01000000 FB_SYMBSTATS_RTL_CONST = &h02000000 @@ -169,6 +169,8 @@ enum FB_SYMBATTRIB FB_SYMBATTRIB_VIS_PRIVATE = &h04000000 '' / FB_SYMBATTRIB_VIS_PROTECTED = &h08000000 '' / FB_SYMBATTRIB_NAKED = &h10000000 + FB_SYMBATTRIB_ABSTRACT = &h20000000 + FB_SYMBATTRIB_VIRTUAL = &h40000000 FB_SYMBATTRIB_LITCONST = FB_SYMBATTRIB_CONST or FB_SYMBATTRIB_LITERAL @@ -425,6 +427,8 @@ type FB_STRUCTEXT opovlTb ( _ 0 to AST_OP_SELFOPS-1 _ ) as FBSYMBOL_ ptr + vtable as FBSYMBOL_ ptr '' virtual-functions table struct + rtti as FBSYMBOL_ ptr '' Run-Time Type Info struct end type type FBS_STRUCT @@ -726,6 +730,12 @@ type FB_GLOBCTORLIST list as TLIST end type +type FB_RTTICTX + fb_rtti as FBSYMBOL ptr + fb_baseVT as FBSYMBOL ptr + fb_object as FBSYMBOL ptr +End Type + type SYMBCTX inited as integer @@ -770,6 +780,8 @@ type SYMBCTX ) as SYMB_OVLOP '' global operator overloading arrdesctype as FBSYMBOL ptr '' array descriptor type + + rtti as FB_RTTICTX end type type SYMB_DATATYPE @@ -1096,7 +1108,8 @@ declare function symbStructBegin _ byval id as zstring ptr, _ byval id_alias as zstring ptr, _ byval isunion as integer, _ - byval align as integer _ + byval align as integer, _ + byval baseStruct as FBSYMBOL ptr = NULL _ ) as FBSYMBOL ptr declare function symbAddField _ @@ -1119,7 +1132,8 @@ declare sub symbInsertInnerUDT _ declare sub symbStructEnd _ ( _ - byval t as FBSYMBOL ptr _ + byval t as FBSYMBOL ptr, _ + byval isnested as integer = FALSE _ ) declare function symbAddEnum _ @@ -2060,8 +2074,8 @@ declare function symbGetUDTBaseSymbol _ #define symbGetHasDtor(s) ((s->stats and FB_SYMBSTATS_HASDTOR) <> 0) #define symbSetHasDtor(s) s->stats or= FB_SYMBSTATS_HASDTOR -#define symbGetHasVirtual(s) ((s->stats and FB_SYMBSTATS_HASVIRTUAL) <> 0) -#define symbSetHasVirtual(s) s->stats or= FB_SYMBSTATS_HASVIRTUAL +#define symbGetHasRTTI(s) ((s->stats and FB_SYMBSTATS_HASRTTI) <> 0) +#define symbSetHasRTTI(s) s->stats or= FB_SYMBSTATS_HASRTTI #define symbGetIsGlobalCtor(s) ((s->stats and FB_SYMBSTATS_GLOBALCTOR) <> 0) #define symbSetIsGlobalCtor( s ) s->stats or= FB_SYMBSTATS_GLOBALCTOR or FB_SYMBSTATS_CALLED @@ -2482,11 +2496,15 @@ declare function symbGetUDTBaseSymbol _ #define symbIsVisProtected(s) ((s->attrib and FB_SYMBATTRIB_VIS_PROTECTED) <> 0) +#define symbIsAbstract(s) ((s->attrib and FB_SYMBATTRIB_ABSTRACT) <> 0) + +#define symbIsVirtual(s) ((s->attrib and FB_SYMBATTRIB_VIRTUAL) <> 0) + #define symbGetProcStaticLocals(s) ((s->attrib and FB_SYMBATTRIB_STATICLOCALS) <> 0) #define symbIsTrivial(s) ((s->stats and (FB_SYMBSTATS_HASCOPYCTOR or _ FB_SYMBSTATS_HASDTOR or _ - FB_SYMBSTATS_HASVIRTUAL)) = 0) + FB_SYMBSTATS_HASRTTI)) = 0) #define symbIsSuffixed(s) ((s->attrib and FB_SYMBATTRIB_SUFFIXED) <> 0) diff --git a/FreeBASIC/src/compiler/ir-hlc.bas b/FreeBASIC/src/compiler/ir-hlc.bas index 482ffc5446..76ca43c47f 100644 --- a/FreeBASIC/src/compiler/ir-hlc.bas +++ b/FreeBASIC/src/compiler/ir-hlc.bas @@ -253,7 +253,11 @@ private function hGetUDTName _ ns = symbGetNamespace( ns ) loop - sig += *symbGetName( s ) + if( s->id.alias <> NULL ) then + sig += *s->id.alias + else + sig += *symbGetName( s ) + EndIf if( need_original_name = FALSE ) then '' see the HACK in hEmitStruct() diff --git a/FreeBASIC/src/compiler/parser-decl-struct.bas b/FreeBASIC/src/compiler/parser-decl-struct.bas index d1a5de6bd9..df4177c090 100644 --- a/FreeBASIC/src/compiler/parser-decl-struct.bas +++ b/FreeBASIC/src/compiler/parser-decl-struct.bas @@ -690,16 +690,14 @@ private function hTypeAdd _ byval id_alias as zstring ptr, _ byval isunion as integer, _ byval align as integer, _ - byval baseDType as integer = FB_DATATYPE_VOID, _ - byval baseSubtype as FBSYMBOL ptr = NULL, _ - byval baseLgt as integer = 0 _ + byval baseSubtype as FBSYMBOL ptr = NULL _ ) as FBSYMBOL ptr dim as FBSYMBOL ptr s = any function = NULL - s = symbStructBegin( parent, id, id_alias, isunion, align ) + s = symbStructBegin( parent, id, id_alias, isunion, align, baseSubtype ) if( s = NULL ) then if( errReportEx( FB_ERRMSG_DUPDEFINITION, id ) = FALSE ) then exit function @@ -724,26 +722,9 @@ private function hTypeAdd _ end if end if - '' any extends? - if( baseDType <> FB_DATATYPE_VOID ) then - static as FBARRAYDIM dTB(0 to 0) - - s->udt.base = symbAddField( s, hMakeTmpStrNL( ), 0, dTB(), baseDtype, baseSubtype, baseLgt, 0 ) - - if( s->udt.base <> NULL ) then - symbNamespaceImportEx( baseSubtype, s ) - End If - end if - - '' TypeBody dim as integer res = hTypeBody( s ) - '' end nesting - if( symbGetIsUnique( s ) ) then - symbNestEnd( FALSE ) - end if - if( res = FALSE ) then exit function else @@ -753,7 +734,7 @@ private function hTypeAdd _ end if '' finalize - symbStructEnd( s ) + symbStructEnd( s, symbGetIsUnique( s ) ) '' END TYPE|UNION if( lexGetToken( ) <> FB_TK_END ) then @@ -1160,12 +1141,12 @@ function cTypeDecl _ '' (EXTENDS SymbolType)? - dim as integer baseDtype, baseLgt dim as FBSYMBOL ptr baseSubtype = NULL if( lexGetToken( ) = FB_TK_EXTENDS ) then lexSkipToken( ) '' SymbolType + dim as integer baseDtype, baseLgt if( hSymbolType( baseDtype, baseSubtype, baseLgt ) = FALSE ) then if( errReport( FB_ERRMSG_EXPECTEDIDENTIFIER ) = FALSE ) then exit function @@ -1181,7 +1162,7 @@ function cTypeDecl _ exit function else '' error recovery: skip - baseDtype = FB_DATATYPE_VOID + baseSubtype = NULL end if end if end if @@ -1244,7 +1225,7 @@ function cTypeDecl _ dim as FBSYMBOL ptr currprocsym = parser.currproc, currblocksym = parser.currblock dim as integer scope_depth = parser.scope - sym = hTypeAdd( NULL, id, palias, isunion, align, baseDtype, baseSubtype, baseLgt ) + sym = hTypeAdd( NULL, id, palias, isunion, align, baseSubtype ) '' restore the context ast.proc.curr = currproc diff --git a/FreeBASIC/src/compiler/symb-comp.bas b/FreeBASIC/src/compiler/symb-comp.bas index ea3c3670ad..1c16fd1e73 100644 --- a/FreeBASIC/src/compiler/symb-comp.bas +++ b/FreeBASIC/src/compiler/symb-comp.bas @@ -34,7 +34,6 @@ type FB_SYMBNEST ns as FBSYMBOL ptr '' prev namespace end type - ''::::: sub symbCompInit dim as integer i @@ -45,7 +44,7 @@ sub symbCompInit '' stackNew( @symb.neststk, 16, len( FB_SYMBNEST ), FALSE ) - + end sub ''::::: @@ -206,6 +205,78 @@ private sub hAddCtor _ end sub +private sub hAddRTTI _ + ( _ + sym as FBSYMBOL ptr _ + ) + + static as FBARRAYDIM dTB(0) + + var mname = *symbGetMangledName( sym ) + + if( sym->udt.ext = NULL ) then + sym->udt.ext = callocate( len( FB_STRUCTEXT ) ) + end if + + '' create a virtual-table struct (extends $fb_BaseVT) + var sname = "_ZTV" + mname + "_type" + var vtableType = symbStructBegin( NULL, sname, sname, FALSE, 0, symb.rtti.fb_baseVT ) + + '' TODO: add this symbol's virtual methods as function pointers with "this" as the first param + + symbStructEnd( vtableType, TRUE ) + + '' create the run-time info instance ($fb_RTTI) + sname = "_ZTS" + *symbGetMangledName( sym ) + var rtti = symbAddVarEx( NULL, sname, _ + FB_DATATYPE_STRUCT, symb.rtti.fb_rtti, _ + symbGetLen( symb.rtti.fb_rtti ), _ + 0, dTB(), _ + FB_SYMBATTRIB_CONST or FB_SYMBATTRIB_STATIC or FB_SYMBATTRIB_SHARED, _ + FB_SYMBOPT_PRESERVECASE ) + + sym->udt.ext->rtti = rtti + + '' initialize.. + var initree = astTypeIniBegin( FB_DATATYPE_STRUCT, symb.rtti.fb_rtti, FALSE, 0 ) + + astTypeIniScopeBegin( initree, rtti ) + + '' stdlistVT = NULL + var elm = symbGetUDTFirstElm( symb.rtti.fb_rtti ) + astTypeIniAddAssign( initree, astNewCONSTi( 0, typeAddrOf( FB_DATATYPE_VOID ), NULL ), elm ) + + '' id = @"mangled name" + elm = symbGetUDTNextElm( elm, FALSE ) + astTypeIniAddAssign( initree, astNewADDROF( astNewVar( symbAllocStrConst( mname, len( mname ) ), 0, FB_DATATYPE_CHAR ) ), elm ) + + '' pRTTIBase = @base's RTTI struct + elm = symbGetUDTNextElm( elm, FALSE ) + astTypeIniAddAssign( initree, astNewADDROF( astNewVar( symbGetSubtype( sym->udt.base )->udt.ext->rtti, 0 ) ), elm ) + + astTypeIniScopeEnd( initree, rtti ) + astTypeIniEnd( initree, TRUE ) + + symbSetTypeIniTree( rtti, initree ) + symbSetIsInitialized( rtti ) + + + '' create the vtable instance + sname = "_ZTV" + mname + + var vtable = symbAddVarEx( NULL, sname, _ + FB_DATATYPE_STRUCT, vtableType, _ + symbGetLen( vtableType ), _ + 0, dTB(), _ + FB_SYMBATTRIB_CONST or FB_SYMBATTRIB_STATIC or FB_SYMBATTRIB_SHARED, _ + FB_SYMBOPT_PRESERVECASE ) + + sym->udt.ext->vtable = vtable + + '' initialize.. + +End Sub + ''::::: private sub hAssignList _ ( _ @@ -379,6 +450,14 @@ sub symbCompAddDefMembers _ byval sym as FBSYMBOL ptr _ ) static + '' RTTI? + if( symbGetHasRTTI( sym ) ) then + '' only if it isn't FB's own Object base super class + if( sym <> symb.rtti.fb_object ) then + hAddRTTI( sym ) + end if + End if + '' has fields with ctors? if( symbGetUDTHasCtorField( sym ) ) then '' any ctor explicitly defined? @@ -407,7 +486,7 @@ sub symbCompAddDefMembers _ hAddCtor( sym, FALSE, FALSE ) end if end if - + end sub '':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: @@ -1145,4 +1224,112 @@ sub symbCompDelImportList _ end sub +'':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: +'' RTTI +'':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + +'':::: +sub symbCompRTTIInit + + static as FBARRAYDIM dTB(0) + + '' create the $fb_RTTI struct + var rtti = symbStructBegin( NULL, "$fb_RTTI", "$fb_RTTI", FALSE, 0 ) + symb.rtti.fb_rtti = rtti + + '' stdlibVT as any ptr + symbAddField( rtti, _ + "stdlibVT", _ + 0, dTB(), _ + typeAddrOf( FB_DATATYPE_VOID ), NULL, _ + FB_POINTERSIZE, 0 ) + + + '' dim id as zstring ptr + symbAddField( rtti, _ + "id", _ + 0, dTB(), _ + typeAddrOf( FB_DATATYPE_CHAR ), NULL, _ + FB_POINTERSIZE, 0 ) + + '' dim pRTTIBase as $fb_RTTI ptr + symbAddField( rtti, _ + "pRTTIBase", _ + 0, dTB(), _ + typeAddrOf( FB_DATATYPE_STRUCT ), rtti, _ + FB_POINTERSIZE, 0 ) + + symbStructEnd( rtti ) + + '' create the $fb_BaseVT struct + var baseVT = symbStructBegin( NULL, "$fb_BaseVT", "$fb_BaseVT", FALSE, 0 ) + symb.rtti.fb_baseVT = baseVT + + '' dim nullPtr as any ptr + symbAddField( baseVT, _ + "nullPtr", _ + 0, dTB(), _ + typeAddrOf( FB_DATATYPE_VOID ), NULL, _ + FB_POINTERSIZE, 0 ) + + '' dim pRTTIBase as $fb_RTTI ptr + symbAddField( baseVT, _ + "pRTTI", _ + 0, dTB(), _ + typeAddrOf( FB_DATATYPE_STRUCT ), rtti, _ + FB_POINTERSIZE, 0 ) + + symbStructEnd( baseVT ) + + '' create the $fb_ObjectVT struct (extends $fb_BaseVT) + var objVT = symbStructBegin( NULL, "$fb_ObjectVT", "$fb_ObjectVT", FALSE, 0, baseVT ) + + symbStructEnd( objVT, TRUE ) + + '' create the $fb_Object struct + var obj = symbStructBegin( NULL, "Object", "$fb_Object", FALSE, 0 ) + symb.rtti.fb_object = obj + + symbSetHasRTTI( obj ) + symbSetIsUnique( obj ) + symbNestBegin( obj, FALSE ) + + '' dim pvt as as $fb_BaseVT ptr + symbAddField( obj, _ + "$fb_pvt", _ + 0, dTB(), _ + typeAddrOf( FB_DATATYPE_STRUCT ), baseVT, _ + FB_POINTERSIZE, 0 ) + + '' declare constructor( ) + var ctor = symbPreAddProc( NULL ) + + symAddProcInstancePtr( obj, ctor ) + + symbAddCtor( ctor, NULL, NULL, _ + FB_SYMBATTRIB_METHOD or FB_SYMBATTRIB_CONSTRUCTOR or FB_SYMBATTRIB_OVERLOADED, FB_FUNCMODE_CDECL ) + + symbStructEnd( obj, TRUE ) + + '' declare extern shared as $fb_RTTI __fb_ZTS6Object (the Object class RTTI instance created in C) + var objRTTI = symbAddVarEx( NULL, "__fb_ZTS6Object", _ + FB_DATATYPE_STRUCT, symb.rtti.fb_rtti, _ + symbGetLen( symb.rtti.fb_rtti ), 0, dTB(), _ + FB_SYMBATTRIB_EXTERN or FB_SYMBATTRIB_SHARED, _ + FB_SYMBOPT.FB_SYMBOPT_PRESERVECASE ) + + + '' update the obj struct RTTI (used to create the link with base classes) + if( obj->udt.ext = NULL ) then + obj->udt.ext = callocate( sizeof( FB_STRUCTEXT ) ) + End If + + obj->udt.ext->rtti = objRTTI + + +End Sub +'':::: +sub symbCompRTTIEnd + +End Sub diff --git a/FreeBASIC/src/compiler/symb-struct.bas b/FreeBASIC/src/compiler/symb-struct.bas index e3e5c54d5d..85271bbc31 100644 --- a/FreeBASIC/src/compiler/symb-struct.bas +++ b/FreeBASIC/src/compiler/symb-struct.bas @@ -40,10 +40,9 @@ function symbStructBegin _ byval id as zstring ptr, _ byval id_alias as zstring ptr, _ byval isunion as integer, _ - byval align as integer _ - ) as FBSYMBOL ptr static - - dim as FBSYMBOL ptr s + byval align as integer, _ + byval base_ as FBSYMBOL ptr _ + ) as FBSYMBOL ptr function = NULL @@ -55,12 +54,12 @@ function symbStructBegin _ end if end if - s = symbNewSymbol( FB_SYMBOPT_DOHASH, _ - NULL, _ - NULL, NULL, _ - FB_SYMBCLASS_STRUCT, _ - id, id_alias, _ - FB_DATATYPE_STRUCT, NULL ) + var s = symbNewSymbol( FB_SYMBOPT_DOHASH, _ + NULL, _ + NULL, NULL, _ + FB_SYMBCLASS_STRUCT, _ + id, id_alias, _ + FB_DATATYPE_STRUCT, NULL ) if( s = NULL ) then exit function end if @@ -98,6 +97,23 @@ function symbStructBegin _ s->udt.dbg.typenum = INVALID s->udt.ext = NULL + + '' extending another UDT? + if( base_ <> NULL ) then + static as FBARRAYDIM dTB(0 to 0) + + s->udt.base = symbAddField( s, "$fb_base", 0, dTB(), FB_DATATYPE_STRUCT, base_, symbGetLen( base_ ), 0 ) + + symbSetIsUnique( s ) + symbNestBegin( s, FALSE ) + symbNamespaceImportEx( base_, s ) + + if( symbGetHasRTTI( base_ ) ) then + symbSetHasRTTI( s ) + End If + else + s->udt.base = NULL + End If function = s @@ -677,11 +693,17 @@ end function ''::::: sub symbStructEnd _ ( _ - byval sym as FBSYMBOL ptr _ + byval sym as FBSYMBOL ptr, _ + byval isnested as integer _ ) static dim as integer pad + '' end nesting? + if( isnested ) then + symbNestEnd( FALSE ) + end if + '' save length w/o padding sym->udt.unpadlgt = sym->lgt diff --git a/FreeBASIC/src/compiler/symb.bas b/FreeBASIC/src/compiler/symb.bas index 1f6fb19322..5a221e229f 100644 --- a/FreeBASIC/src/compiler/symb.bas +++ b/FreeBASIC/src/compiler/symb.bas @@ -62,6 +62,11 @@ declare sub symbCompInit ( ) declare sub symbCompEnd ( ) +declare sub symbCompRTTIInit ( ) + +declare sub symbCompRTTIEnd ( ) + + ''globals dim shared as SYMBCTX symb @@ -178,6 +183,9 @@ sub symbInit _ '' hInitDefTypeTb( ) + + '' + symbCompRTTIInit( ) '' symb.inited = TRUE @@ -208,6 +216,9 @@ sub symbEnd '' hashFree( @symb.globnspc.nspc.ns.hashtb.tb ) + '' + symbCompRTTIEnd( ) + '' symbProcEnd( ) From f419c442eb9139de7ea3445c0e006b26481b33cb Mon Sep 17 00:00:00 2001 From: v1ctor Date: Sun, 3 Apr 2011 01:13:26 +0000 Subject: [PATCH 10/17] changed: inheritance (more WIP) r5476 --- FreeBASIC/src/compiler/Makefile.in | 2 +- FreeBASIC/src/compiler/ast-node-bop.bas | 23 +++- FreeBASIC/src/compiler/ast-node-proc.bas | 29 +++++ FreeBASIC/src/compiler/ast.bas | 6 + FreeBASIC/src/compiler/error.bas | 5 +- FreeBASIC/src/compiler/inc/ast-op.bi | 1 + FreeBASIC/src/compiler/inc/error.bi | 3 + FreeBASIC/src/compiler/inc/rtl.bi | 10 ++ FreeBASIC/src/compiler/parser-expr-binary.bas | 110 +++++++++++++++++- FreeBASIC/src/compiler/rtl-oop.bas | 88 ++++++++++++++ FreeBASIC/src/compiler/rtl.bas | 4 + FreeBASIC/src/compiler/symb-comp.bas | 30 ++++- 12 files changed, 296 insertions(+), 15 deletions(-) create mode 100644 FreeBASIC/src/compiler/rtl-oop.bas diff --git a/FreeBASIC/src/compiler/Makefile.in b/FreeBASIC/src/compiler/Makefile.in index e5113c271f..64c591e87f 100644 --- a/FreeBASIC/src/compiler/Makefile.in +++ b/FreeBASIC/src/compiler/Makefile.in @@ -342,7 +342,7 @@ FBC_SRCS += reg.bas FBC_SRCS += rtl.bas rtl-array.bas rtl-console.bas rtl-data.bas rtl-error.bas FBC_SRCS += rtl-file.bas rtl-gfx.bas rtl-gosub.bas rtl-macro.bas rtl-math.bas rtl-mem.bas -FBC_SRCS += rtl-print.bas rtl-profile.bas rtl-string.bas rtl-system.bas +FBC_SRCS += rtl-print.bas rtl-profile.bas rtl-string.bas rtl-system.bas rtl-oop.bas FBC_SRCS += symb.bas symb-const.bas symb-data.bas symb-define.bas symb-enum.bas FBC_SRCS += symb-keyword.bas symb-label.bas symb-lib.bas symb-proc.bas symb-scope.bas diff --git a/FreeBASIC/src/compiler/ast-node-bop.bas b/FreeBASIC/src/compiler/ast-node-bop.bas index c613e0b1e8..03c307a9d8 100644 --- a/FreeBASIC/src/compiler/ast-node-bop.bas +++ b/FreeBASIC/src/compiler/ast-node-bop.bas @@ -873,6 +873,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 _ ( _ @@ -896,13 +909,17 @@ function astNewBOP _ is_str = FALSE - '' special case.. - if( op = AST_OP_CONCAT ) then + '' special cases.. + select case op + case AST_OP_CONCAT if( hToStr( l, r ) = FALSE ) then exit function end if op = AST_OP_ADD - end if + + case AST_OP_IS + return hCmpDynType( l, r ) + End Select ldtype = astGetFullType( l ) rdtype = astGetFullType( r ) diff --git a/FreeBASIC/src/compiler/ast-node-proc.bas b/FreeBASIC/src/compiler/ast-node-proc.bas index c21c5afbb8..cd82454951 100644 --- a/FreeBASIC/src/compiler/ast-node-proc.bas +++ b/FreeBASIC/src/compiler/ast-node-proc.bas @@ -1128,6 +1128,32 @@ private sub hCallBaseCtors _ End Sub +''::::: +private sub hInitVtable _ + ( _ + byval parent as FBSYMBOL ptr, _ + byval proc as FBSYMBOL ptr _ + ) + + if( symbGetHasRTTI( parent ) = FALSE ) then + exit sub + End If + + if( parent->udt.ext = NULL ) then + exit sub + End If + + var this_ = symbGetParamVar( symbGetProcHeadParam( proc ) ) + + '' this.pvt = cast( any ptr, (cast(byte ptr, @vtable) + sizeof(void *) * 2) ) + astAdd( _ + astNewASSIGN( _ + astBuildInstPtr( this_, symbGetUDTFirstElm( symb.rtti.fb_object ) ), _ + astNewCONV( typeAddrOf( FB_DATATYPE_VOID ), NULL, _ + astNewADDROF( astNewVAR( parent->udt.ext->vtable, FB_POINTERSIZE*2 ) ) ) ) ) + +End Sub + ''::::: private sub hCallCtors _ ( _ @@ -1143,6 +1169,9 @@ private sub hCallCtors _ '' 2nd) field ctors hCallFieldCtors( parent, proc ) + + '' 3rd) setup de vtable ptr + hInitVtable( parent, proc ) end sub diff --git a/FreeBASIC/src/compiler/ast.bas b/FreeBASIC/src/compiler/ast.bas index 25a1cc95a7..06d6142288 100644 --- a/FreeBASIC/src/compiler/ast.bas +++ b/FreeBASIC/src/compiler/ast.bas @@ -627,6 +627,12 @@ declare sub astDelCALL _ AST_OPFLAGS_NONE, _ @"<=" _ ), _ + /' AST_OP_IS '/ _ + ( _ + AST_NODECLASS_COMP, _ + AST_OPFLAGS_NONE, _ + @"is" _ + ), _ /' AST_OP_NOT '/ _ ( _ AST_NODECLASS_UOP, _ diff --git a/FreeBASIC/src/compiler/error.bas b/FreeBASIC/src/compiler/error.bas index 81e48f12ae..6d77da9ac7 100644 --- a/FreeBASIC/src/compiler/error.bas +++ b/FreeBASIC/src/compiler/error.bas @@ -313,7 +313,10 @@ end type @"TYPE can only extend other TYPE symbols", _ @"Illegal outside a CLASS, TYPE or UNION method", _ @"CLASS, TYPE or UNION not derived", _ - @"CLASS, TYPE or UNION has no constructor" _ + @"CLASS, TYPE or UNION has no constructor", _ + @"Symbol type has no Run-Time Type Info (RTTI)", _ + @"Types have no hierarchical relation", _ + @"Expected a CLASS, TYPE or UNION symbol type" _ } diff --git a/FreeBASIC/src/compiler/inc/ast-op.bi b/FreeBASIC/src/compiler/inc/ast-op.bi index f856603000..96d09e428c 100644 --- a/FreeBASIC/src/compiler/inc/ast-op.bi +++ b/FreeBASIC/src/compiler/inc/ast-op.bi @@ -75,6 +75,7 @@ enum AST_OP AST_OP_NE AST_OP_GE AST_OP_LE + AST_OP_IS AST_OP_NOT AST_OP_PLUS diff --git a/FreeBASIC/src/compiler/inc/error.bi b/FreeBASIC/src/compiler/inc/error.bi index d8f091d831..eab48386a6 100644 --- a/FreeBASIC/src/compiler/inc/error.bi +++ b/FreeBASIC/src/compiler/inc/error.bi @@ -262,6 +262,9 @@ enum FB_ERRMSG FB_ERRMSG_ILLEGALOUTSIDEAMETHOD FB_ERRMSG_CLASSNOTDERIVED FB_ERRMSG_CLASSWITHOUTCTOR + FB_ERRMSG_TYPEHASNORTTI + FB_ERRMSG_TYPESARENOTRELATED + FB_ERRMSG_TYPEMUSTBEAUDT FB_ERRMSGS end enum diff --git a/FreeBASIC/src/compiler/inc/rtl.bi b/FreeBASIC/src/compiler/inc/rtl.bi index 7ca304ba03..82b02869c9 100644 --- a/FreeBASIC/src/compiler/inc/rtl.bi +++ b/FreeBASIC/src/compiler/inc/rtl.bi @@ -159,6 +159,8 @@ #define FB_RTL_NULLPTRCHK "fb_NullPtrChk" +#define FB_RTL_ISTYPEOF "fb_IsTypeOf" + #define FB_RTL_CPUDETECT "fb_CpuDetect" #define FB_RTL_INIT "fb_Init" #define FB_RTL_INITSIGNALS "fb_InitSignals" @@ -548,6 +550,8 @@ enum FB_RTL_IDX FB_RTL_IDX_ARRAYBOUNDCHK FB_RTL_IDX_NULLPTRCHK + + FB_RTL_IDX_ISTYPEOF FB_RTL_IDX_CPUDETECT FB_RTL_IDX_INIT @@ -1274,6 +1278,12 @@ declare function rtlMemDeleteOp _ byval subtype as FBSYMBOL ptr _ ) as ASTNODE ptr +declare function rtlOOPIsTypeOf _ + ( _ + byval inst as ASTNODE ptr, _ + byval rtti as ASTNODE ptr _ + ) as ASTNODE ptr + declare function rtlPrint _ ( _ byval fileexpr as ASTNODE ptr, _ diff --git a/FreeBASIC/src/compiler/parser-expr-binary.bas b/FreeBASIC/src/compiler/parser-expr-binary.bas index 88b068a8b2..29a47c0aac 100644 --- a/FreeBASIC/src/compiler/parser-expr-binary.bas +++ b/FreeBASIC/src/compiler/parser-expr-binary.bas @@ -37,6 +37,11 @@ declare function cLogAndExpression _ _ ) as ASTNODE ptr +declare function cIsExpression _ + ( _ + _ + ) as ASTNODE ptr + ''::::: ''Expression = LogExpression . '' @@ -283,7 +288,7 @@ function cLogAndExpression _ end function ''::::: -''RelExpression = CatExpression ( (EQ | GT | LT | NE | LE | GE) CatExpression )* . +''RelExpression = IsExpression ( (EQ | GT | LT | NE | LE | GE) IsExpression )* . '' function cRelExpression _ ( _ @@ -293,8 +298,8 @@ function cRelExpression _ dim as integer op = any dim as ASTNODE ptr expr = any, relexpr = any - '' CatExpression - relexpr = cCatExpression( ) + '' IsExpression + relexpr = cIsExpression( ) if( relexpr = NULL ) then return NULL end if @@ -327,8 +332,8 @@ function cRelExpression _ lexSkipToken( ) - '' CatExpression - expr = cCatExpression( ) + '' IsExpression + expr = cIsExpression( ) if( expr = NULL ) then if( errReport( FB_ERRMSG_EXPECTEDEXPRESSION ) = FALSE ) then return NULL @@ -354,6 +359,101 @@ function cRelExpression _ end function +''::::: +''IsExpression = CatExpression IS SymbolType . +'' +function cIsExpression _ + ( _ + _ + ) as ASTNODE ptr + + '' CatExpression + dim as ASTNODE ptr isexpr = cCatExpression( ) + if( isexpr = NULL ) then + return NULL + end if + + '' IS? + if( lexGetToken( ) <> FB_TK_IS ) then + return isexpr + end if + + '' must be a struct with RTTI info + if( astGetDataType( isexpr ) = FB_DATATYPE_STRUCT ) then + if( symbGetHasRTTI( astGetSubtype( isexpr ) ) = FALSE ) then + if( errReport( FB_ERRMSG_TYPEHASNORTTI ) = FALSE ) then + return NULL + else + '' error recovery: fake a node + isexpr = astNewCONSTi( 0, FB_DATATYPE_INTEGER ) + end if + end if + else + if( errReport( FB_ERRMSG_TYPEMUSTBEAUDT ) = FALSE ) then + return NULL + else + '' error recovery: fake a node + isexpr = astNewCONSTi( 0, FB_DATATYPE_INTEGER ) + end if + End if + + lexSkipToken( ) + + '' SymbolType + dim as integer dtype = any + dim as FBSYMBOL ptr subtype = any + dim as integer lgt = any + if( cSymbolType( dtype, subtype, lgt ) = FALSE ) then + return NULL + end if + + '' must be a struct type with RTTI info + if( typeGetDtAndPtrOnly( dtype ) = FB_DATATYPE_STRUCT ) then + if( symbGetHasRTTI( subtype ) = FALSE ) then + if( errReport( FB_ERRMSG_TYPEHASNORTTI ) = FALSE ) then + return NULL + else + '' error recovery: fake a node + return astNewCONSTi( 0, FB_DATATYPE_INTEGER ) + end if + + elseif( symbGetUDTBaseLevel( subtype, astGetSubtype( isexpr ) ) = 0 ) then + if( errReport( FB_ERRMSG_TYPESARENOTRELATED ) = FALSE ) then + return NULL + else + '' error recovery: fake a node + return astNewCONSTi( 0, FB_DATATYPE_INTEGER ) + end if + + end if + else + if( errReport( FB_ERRMSG_TYPEMUSTBEAUDT ) = FALSE ) then + return NULL + else + '' error recovery: fake a node + return astNewCONSTi( 0, FB_DATATYPE_INTEGER ) + end if + end if + + '' point to the RTTI table + var expr = astNewVAR( subtype->udt.ext->rtti ) + + '' do operation + isexpr = astNewBOP( AST_OP_IS, isexpr, expr ) + + if( isexpr = NULL ) Then + if( errReport( FB_ERRMSG_TYPEMISMATCH ) = FALSE ) then + return NULL + else + '' error recovery: fake a node + isexpr = astNewCONSTi( 0, FB_DATATYPE_INTEGER ) + end if + end if + + function = isexpr + +end function + ''::::: ''CatExpression = AddExpression ( & AddExpression )* . '' diff --git a/FreeBASIC/src/compiler/rtl-oop.bas b/FreeBASIC/src/compiler/rtl-oop.bas new file mode 100644 index 0000000000..14f9b85a28 --- /dev/null +++ b/FreeBASIC/src/compiler/rtl-oop.bas @@ -0,0 +1,88 @@ +'' FreeBASIC - 32-bit BASIC Compiler. +'' Copyright (C) 2004-2010 The FreeBASIC development team. +'' +'' This program is free software; you can redistribute it and/or modify +'' it under the terms of the GNU General Public License as published by +'' the Free Software Foundation; either version 2 of the License, or +'' (at your option) any later version. +'' +'' This program is distributed in the hope that it will be useful, +'' but WITHOUT ANY WARRANTY; without even the implied warranty of +'' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +'' GNU General Public License for more details. +'' +'' You should have received a copy of the GNU General Public License +'' along with this program; if not, write to the Free Software +'' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + + +'' intrinsic runtime lib OOP functions (is operator, dynamic cast, ...) +'' +'' chng: apr/2011 written [v1ctor] + + +#include once "inc\fb.bi" +#include once "inc\fbint.bi" +#include once "inc\ast.bi" +#include once "inc\rtl.bi" + + dim shared as FB_RTL_PROCDEF funcdata( 0 to 3 ) = _ + { _ + /' fb_IsTypeOf ( byref obj as any, byref rtti as $fb_RTTI ) as integer '/ _ + ( _ + @FB_RTL_ISTYPEOF, NULL, _ + FB_DATATYPE_INTEGER, FB_FUNCMODE_STDCALL, _ + NULL, FB_RTL_OPT_NONE, _ + 2, _ + { _ + ( _ + FB_DATATYPE_VOID,FB_PARAMMODE_BYREF, FALSE _ + ), _ + ( _ + FB_DATATYPE_VOID,FB_PARAMMODE_BYREF, FALSE _ + ) _ + } _ + ), _ + /' EOL '/ _ + ( _ + NULL _ + ) _ + } + +''::::: +sub rtlOOPModInit( ) + + rtlAddIntrinsicProcs( @funcdata(0) ) + +end sub + +''::::: +sub rtlOOPModEnd( ) + + '' procs will be deleted when symbEnd is called + +end sub + +''::::: +function rtlOOPIsTypeOf _ + ( _ + byval inst as ASTNODE ptr, _ + byval rtti as ASTNODE ptr _ + ) as ASTNODE ptr + + + var proc = astNewCALL( PROCLOOKUP( ISTYPEOF ) ) + + '' byref obj as any ptr + if( astNewARG( proc, inst ) = NULL ) then + exit function + end if + + '' byref rtti as any ptr + if( astNewARG( proc, rtti ) = NULL ) then + exit function + end if + + function = proc + +end function diff --git a/FreeBASIC/src/compiler/rtl.bas b/FreeBASIC/src/compiler/rtl.bas index 595a512a6b..243f9d66b7 100644 --- a/FreeBASIC/src/compiler/rtl.bas +++ b/FreeBASIC/src/compiler/rtl.bas @@ -40,6 +40,7 @@ declare sub rtlProfileModInit ( ) declare sub rtlStringModInit ( ) declare sub rtlSystemModInit ( ) declare sub rtlGosubModInit ( ) +declare sub rtlOOPModInit ( ) declare sub rtlArrayModEnd ( ) declare sub rtlConsoleModEnd ( ) @@ -55,6 +56,7 @@ declare sub rtlProfileModEnd ( ) declare sub rtlStringModEnd ( ) declare sub rtlSystemModEnd ( ) declare sub rtlGosubModEnd ( ) +declare sub rtlOOPModEnd ( ) type RTLCTX @@ -85,12 +87,14 @@ sub rtlInit static rtlStringModInit( ) rtlSystemModInit( ) rtlGosubModInit( ) + rtlOOPModInit( ) end sub ''::::: sub rtlEnd + rtlOOPModEnd( ) rtlGosubModEnd( ) rtlSystemModEnd( ) rtlStringModEnd( ) diff --git a/FreeBASIC/src/compiler/symb-comp.bas b/FreeBASIC/src/compiler/symb-comp.bas index 1c16fd1e73..2862c31cfc 100644 --- a/FreeBASIC/src/compiler/symb-comp.bas +++ b/FreeBASIC/src/compiler/symb-comp.bas @@ -238,8 +238,7 @@ private sub hAddRTTI _ sym->udt.ext->rtti = rtti '' initialize.. - var initree = astTypeIniBegin( FB_DATATYPE_STRUCT, symb.rtti.fb_rtti, FALSE, 0 ) - + var initree = astTypeIniBegin( FB_DATATYPE_STRUCT, symb.rtti.fb_rtti, FALSE, 0 ) astTypeIniScopeBegin( initree, rtti ) '' stdlistVT = NULL @@ -247,12 +246,14 @@ private sub hAddRTTI _ astTypeIniAddAssign( initree, astNewCONSTi( 0, typeAddrOf( FB_DATATYPE_VOID ), NULL ), elm ) '' id = @"mangled name" - elm = symbGetUDTNextElm( elm, FALSE ) - astTypeIniAddAssign( initree, astNewADDROF( astNewVar( symbAllocStrConst( mname, len( mname ) ), 0, FB_DATATYPE_CHAR ) ), elm ) + elm = symbGetUDTNextElm( elm, FALSE ) + astTypeIniSeparator( initree, rtti ) + astTypeIniAddAssign( initree, astNewADDROF( astNewVAR( symbAllocStrConst( mname, len( mname ) ), 0, FB_DATATYPE_CHAR ) ), elm ) '' pRTTIBase = @base's RTTI struct elm = symbGetUDTNextElm( elm, FALSE ) - astTypeIniAddAssign( initree, astNewADDROF( astNewVar( symbGetSubtype( sym->udt.base )->udt.ext->rtti, 0 ) ), elm ) + astTypeIniSeparator( initree, rtti ) + astTypeIniAddAssign( initree, astNewADDROF( astNewVAR( symbGetSubtype( sym->udt.base )->udt.ext->rtti, 0 ) ), elm ) astTypeIniScopeEnd( initree, rtti ) astTypeIniEnd( initree, TRUE ) @@ -274,6 +275,25 @@ private sub hAddRTTI _ sym->udt.ext->vtable = vtable '' initialize.. + initree = astTypeIniBegin( FB_DATATYPE_STRUCT, vtableType, FALSE, 0 ) + astTypeIniScopeBegin( initree, vtable ) + astTypeIniScopeBegin( initree, vtable ) + + '' base.nullPtr = NULL + elm = symbGetUDTFirstElm( symb.rtti.fb_baseVT ) + astTypeIniAddAssign( initree, astNewCONSTi( 0, typeAddrOf( FB_DATATYPE_VOID ), NULL ), elm ) + + '' base.pRTTI = @rtti + elm = symbGetUDTNextElm( elm, FALSE ) + astTypeIniSeparator( initree, vtable ) + astTypeIniAddAssign( initree, astNewADDROF( astNewVAR( rtti, 0 ) ), elm ) + + astTypeIniScopeEnd( initree, vtable ) + astTypeIniScopeEnd( initree, vtable ) + astTypeIniEnd( initree, TRUE ) + + symbSetTypeIniTree( vtable, initree ) + symbSetIsInitialized( vtable ) End Sub From 0adc8c68a90b15089600dfde77e7a2a896496ecf Mon Sep 17 00:00:00 2001 From: dkl Date: Wed, 20 Apr 2011 14:32:50 +0000 Subject: [PATCH 11/17] Fixed FOR loops with UDT PTR iterators r5527 --- FreeBASIC/src/compiler/parser-compound-for.bas | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/FreeBASIC/src/compiler/parser-compound-for.bas b/FreeBASIC/src/compiler/parser-compound-for.bas index 3ee7e4f332..85559a6529 100644 --- a/FreeBASIC/src/compiler/parser-compound-for.bas +++ b/FreeBASIC/src/compiler/parser-compound-for.bas @@ -484,7 +484,7 @@ private function hForAssign _ '' initial condition is a non-UDT constant? if( astIsCONST( expr ) and ((flags and FOR_ISUDT) = 0) ) then '' convert the constant to counter's type - expr = astNewCONV( dtype, NULL, expr ) + expr = astNewCONV( dtype, subtype, expr ) if( expr = NULL ) then if( errReport( FB_ERRMSG_INVALIDDATATYPES ) = FALSE ) then exit function @@ -569,7 +569,7 @@ private function hForTo _ '' EndCondition is a non-UDT constant? if( astIsCONST( expr ) and ((flags and FOR_ISUDT) = 0) ) then - expr = astNewCONV( dtype, NULL, expr ) + expr = astNewCONV( dtype, subtype, expr ) if( expr = NULL ) then if( errReport( FB_ERRMSG_INVALIDDATATYPES ) = FALSE ) then exit function @@ -695,7 +695,7 @@ private function hForStep _ '' non-UDT constant? if( astIsCONST( expr ) and ((flags and FOR_ISUDT) = 0) ) then - expr = astNewCONV( dtype, NULL, expr ) + expr = astNewCONV( dtype, subtype, expr ) if( expr = NULL ) then if( errReport( FB_ERRMSG_INVALIDDATATYPES ) = FALSE ) then exit function From f2d23d701cfd8368fc00f3f95bbac6b0a0f0765b Mon Sep 17 00:00:00 2001 From: dkl Date: Wed, 20 Apr 2011 14:34:28 +0000 Subject: [PATCH 12/17] Fixed static member procedure calls r5528 --- FreeBASIC/src/compiler/inc/parser.bi | 8 ++++ .../src/compiler/parser-expr-function.bas | 15 +----- FreeBASIC/src/compiler/parser-proccall.bas | 47 ++++++++++++++----- 3 files changed, 43 insertions(+), 27 deletions(-) diff --git a/FreeBASIC/src/compiler/inc/parser.bi b/FreeBASIC/src/compiler/inc/parser.bi index 0511180f34..c2221aa306 100644 --- a/FreeBASIC/src/compiler/inc/parser.bi +++ b/FreeBASIC/src/compiler/inc/parser.bi @@ -864,6 +864,14 @@ declare function cFunctionCall _ byval thisexpr as ASTNODE ptr = NULL _ ) as ASTNODE ptr +declare sub hMethodCallAddInstPtrOvlArg _ + ( _ + byval proc as FBSYMBOL ptr, _ + byval thisexpr as ASTNODE ptr, _ + byval arg_list as FB_CALL_ARG_LIST ptr, _ + byval options as FB_PARSEROPT ptr _ + ) + declare function cProcCall _ ( _ byval base_parent as FBSYMBOL ptr, _ diff --git a/FreeBASIC/src/compiler/parser-expr-function.bas b/FreeBASIC/src/compiler/parser-expr-function.bas index 725434d38f..2ecdd7a02b 100644 --- a/FreeBASIC/src/compiler/parser-expr-function.bas +++ b/FreeBASIC/src/compiler/parser-expr-function.bas @@ -60,20 +60,7 @@ function cFunctionCall _ dim as FB_PARSEROPT options = FB_PARSEROPT_ISFUNC - '' method call? - if( thisexpr <> NULL ) then - dim as FB_CALL_ARG ptr arg = symbAllocOvlCallArg( @parser.ovlarglist, @arg_list, FALSE ) - - var instParam = symbGetProcHeadParam( sym ) - if( astGetSubtype( thisexpr ) <> symbGetSubtype( instParam ) ) then - thisexpr = astNewCONV( symbGetType( instParam ), symbGetSubType( instParam ), thisexpr ) - EndIf - - arg->expr = thisexpr - - arg->mode = hGetInstPtrMode( thisexpr ) - options or= FB_PARSEROPT_HASINSTPTR - end if + hMethodCallAddInstPtrOvlArg( sym, thisexpr, @arg_list, @options ) '' property? if( symbIsProperty( sym ) ) then diff --git a/FreeBASIC/src/compiler/parser-proccall.bas b/FreeBASIC/src/compiler/parser-proccall.bas index a0b8ab6a13..023d169786 100644 --- a/FreeBASIC/src/compiler/parser-proccall.bas +++ b/FreeBASIC/src/compiler/parser-proccall.bas @@ -181,6 +181,39 @@ function cAssignFunctResult _ end function +sub hMethodCallAddInstPtrOvlArg _ + ( _ + byval proc as FBSYMBOL ptr, _ + byval thisexpr as ASTNODE ptr, _ + byval arg_list as FB_CALL_ARG_LIST ptr, _ + byval options as FB_PARSEROPT ptr _ + ) + + '' Only for method calls + if( thisexpr = NULL ) then + return + end if + + '' The proc given here can be a method with THIS pointer or a static + '' member proc, depending on which was declared/found first, but it's + '' not known yet whether the exact overload that's going to be called + '' will be static or not. So the thisexpr needs to be preserved here, + '' the rest is done after the args were parsed. + + dim as FB_CALL_ARG ptr arg = symbAllocOvlCallArg( @parser.ovlarglist, arg_list, FALSE ) + + dim as FBSYMBOL ptr parent = symbGetParent( proc ) + if( astGetSubtype( thisexpr ) <> parent ) then + thisexpr = astNewCONV( symbGetType( parent ), parent, thisexpr ) + end if + + arg->expr = thisexpr + arg->mode = hGetInstPtrMode( thisexpr ) + + *options or= FB_PARSEROPT_HASINSTPTR + +end sub + ''::::: function cProcCall _ ( _ @@ -200,19 +233,7 @@ function cProcCall _ dim as FB_PARSEROPT options = FB_PARSEROPT_NONE - '' method call? - if( thisexpr <> NULL ) then - dim as FB_CALL_ARG ptr arg = symbAllocOvlCallArg( @parser.ovlarglist, @arg_list, FALSE ) - - var instParam = symbGetProcHeadParam( sym ) - if( astGetSubtype( thisexpr ) <> symbGetSubtype( instParam ) ) then - thisexpr = astNewCONV( symbGetType( instParam ), symbGetSubType( instParam ), thisexpr ) - EndIf - - arg->expr = thisexpr - arg->mode = hGetInstPtrMode( thisexpr ) - options or= FB_PARSEROPT_HASINSTPTR - end if + hMethodCallAddInstPtrOvlArg( sym, thisexpr, @arg_list, @options ) '' property? if( symbIsProperty( sym ) ) then From 4b58f80db5dde779959b8fe4bfdb2a635673387b Mon Sep 17 00:00:00 2001 From: dkl Date: Fri, 6 May 2011 11:28:38 +0000 Subject: [PATCH 13/17] Removed symbIsChildOf(), not needed for PROTECTED access check r5559 --- FreeBASIC/src/compiler/inc/symb.bi | 6 ------ FreeBASIC/src/compiler/symb.bas | 34 +++--------------------------- 2 files changed, 3 insertions(+), 37 deletions(-) diff --git a/FreeBASIC/src/compiler/inc/symb.bi b/FreeBASIC/src/compiler/inc/symb.bi index 282b5b2f10..e79c9289b9 100644 --- a/FreeBASIC/src/compiler/inc/symb.bi +++ b/FreeBASIC/src/compiler/inc/symb.bi @@ -1827,12 +1827,6 @@ declare function symbGetCStdType _ byval ctype as FB_CSTDTYPE _ ) as integer -declare function symbIsChildOf _ - ( _ - byval sym as FBSYMBOL ptr, _ - byval parent as FBSYMBOL ptr _ - ) as integer - declare function symbCheckAccess _ ( _ byval parent as FBSYMBOL ptr, _ diff --git a/FreeBASIC/src/compiler/symb.bas b/FreeBASIC/src/compiler/symb.bas index 5a221e229f..ea86852671 100644 --- a/FreeBASIC/src/compiler/symb.bas +++ b/FreeBASIC/src/compiler/symb.bas @@ -1936,29 +1936,6 @@ function symbCalcLen _ end function -''::::: -function symbIsChildOf _ - ( _ - byval sym as FBSYMBOL ptr, _ - byval parent as FBSYMBOL ptr _ - ) as integer - - do - if( sym = @symbGetGlobalNamespc( ) ) then - return FALSE - end if - - if( sym = parent ) then - return TRUE - end if - - sym = symbGetNamespace( sym ) - loop - - function = FALSE - -end function - ''::::: function symbCheckAccess _ ( _ @@ -1991,14 +1968,9 @@ function symbCheckAccess _ base_ = symbGetSubtype( base_ )->udt.base loop - - return FALSE - - case else - '' symbol is from a child namespace? - return symbIsChildOf( parent, ns ) - End Select - + end select + + return FALSE end if end if From 9ac30a49b68d53075750cf6148ab6b050aed87fe Mon Sep 17 00:00:00 2001 From: dkl Date: Sat, 5 Nov 2011 14:16:09 +0100 Subject: [PATCH 14/17] Fix silent parameter shift (same as 9e8e1d0, just in new inheritance code) --- compiler/symb-comp.bas | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/compiler/symb-comp.bas b/compiler/symb-comp.bas index 62e1dfc777..e5e9804213 100644 --- a/compiler/symb-comp.bas +++ b/compiler/symb-comp.bas @@ -1304,9 +1304,11 @@ sub symbCompRTTIInit symAddProcInstancePtr( obj, ctor ) - symbAddCtor( ctor, NULL, NULL, _ - FB_SYMBATTRIB_METHOD or FB_SYMBATTRIB_CONSTRUCTOR or FB_SYMBATTRIB_OVERLOADED, FB_FUNCMODE_CDECL ) - + symbAddCtor( ctor, NULL, _ + FB_SYMBATTRIB_METHOD or FB_SYMBATTRIB_CONSTRUCTOR _ + or FB_SYMBATTRIB_OVERLOADED, _ + FB_FUNCMODE_CDECL ) + symbStructEnd( obj, TRUE ) '' declare extern shared as $fb_RTTI __fb_ZTS6Object (the Object class RTTI instance created in C) From e27e4077009e583818b734390c323a096876493f Mon Sep 17 00:00:00 2001 From: dkl Date: Sat, 19 Nov 2011 14:50:48 +0100 Subject: [PATCH 15/17] Add back implicit ctor calls for arg -> byref params (e91e517 regression) --- compiler/ast-node-arg.bas | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/compiler/ast-node-arg.bas b/compiler/ast-node-arg.bas index 2e74d45763..3c140e2d29 100644 --- a/compiler/ast-node-arg.bas +++ b/compiler/ast-node-arg.bas @@ -799,10 +799,12 @@ private function hCheckUDTParam _ if( arg = NULL ) then hParamError( parent ) return FALSE - End If + end if n->l = arg - End If - + 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 ) From f31d91631bc0aa3f1811de242b35565afbd56d4c Mon Sep 17 00:00:00 2001 From: dkl Date: Sat, 19 Nov 2011 16:16:37 +0100 Subject: [PATCH 16/17] Fix two log tests that were using "object" as identifier --- tests/scopes/dtor_eol_eof1.bas | 8 ++++---- tests/scopes/dtor_eol_eof2.bas | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/scopes/dtor_eol_eof1.bas b/tests/scopes/dtor_eol_eof1.bas index 5813878909..835b612952 100644 --- a/tests/scopes/dtor_eol_eof1.bas +++ b/tests/scopes/dtor_eol_eof1.bas @@ -4,17 +4,17 @@ dim shared as integer ctors = 0, dtors = 0 -type object +type T as integer a declare constructor() declare destructor() end type -constructor object() +constructor T() ctors += 1 end constructor -destructor object() +destructor T() dtors += 1 end destructor @@ -24,7 +24,7 @@ sub check () destructor if( dtors <> 1 ) then end 2 end sub -dim as object obj +dim as T obj do exit do diff --git a/tests/scopes/dtor_eol_eof2.bas b/tests/scopes/dtor_eol_eof2.bas index 25af7e1968..d0d5e4c429 100644 --- a/tests/scopes/dtor_eol_eof2.bas +++ b/tests/scopes/dtor_eol_eof2.bas @@ -4,17 +4,17 @@ dim shared as integer ctors = 0, dtors = 0 -type object +type T as integer a declare constructor() declare destructor() end type -constructor object() +constructor T() ctors += 1 end constructor -destructor object() +destructor T() dtors += 1 end destructor @@ -24,7 +24,7 @@ sub check () destructor if( dtors <> 1 ) then end 2 end sub -dim as object obj +dim as T obj dim as integer i = 0 do From 072181c4a7388081ae5f8fc00bbf9f9631dca073 Mon Sep 17 00:00:00 2001 From: dkl Date: Sun, 20 Nov 2011 16:19:21 +0100 Subject: [PATCH 17/17] Add some changelog items for the new features --- changelog.txt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/changelog.txt b/changelog.txt index 01a7da7120..289905597e 100644 --- a/changelog.txt +++ b/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)