Merge pull request #150 from jayrm/udt-wstring

user defined types can extend zstring or wstring

Author: jayrm

changelog.txt

@@ -1,13 +1,28 @@
 Version 1.07.0
 
 [changed]
+- SADD/STRPTR(wstring) returns WSTRING PTR
 
 [added]
 - CVA_LIST type, CVA_START(), CVA_COPY() CVA_END(), CVA_ARG() macros will map to gcc's __builtin_va_list and __builtin_va_* macros in gcc backend
 - github #133: fbc makefile supports bootstrap-minimal target to build a bootstrap fbc with only the minimal features necessary to build another fbc. (William Breathitt Gray)
 - github #141: introduced '-strip'/'-nostrip' options to control symbol stripping of output files (William Breathitt Gray)
 - github #141: fbc will default to stripping symbols if '-d ENABLE_STRIPALL' is passed in FBCFLAGS (William Breathitt Gray)
 - github #141: makefile option 'ENABLE_STRIPALL=1' introduced to pass '-d ENABLE_STRIPALL' via FBCFLAGS by default for dos/win32 targets (William Breathitt Gray)
+- 'TYPE udt EXTENDS Z|WSTRING' allowed to specify that UDT is a kind of Z|WSTRING
+- LTRIM/RTRIM/TRIM will accept UDT as Z|WSTRING
+- LCASE/UCASE will accept UDT as Z|WSTRING
+- Cxxx() conversion functions will accept UDT as Z|WSTRING
+- INSTR/INSTRREV will accept UDT as Z|WSTRING
+- MID function will accept UDT as Z|WSTRING
+- SADD/STRPTR will accept UDT as Z|WSTRING to return Z|WSTRING ptr
+- LSET/RSET statements will accept UDT as Z|WSTRING
+- MID statement will accept UDT as Z|WSTRING
+- ASC function will accept UDT as Z|WSTRING
+- STR/WSTR function will accept UDT as Z|WSTRING to return a Z|WSTRING
+- SELECT statement will accept UDT as Z|WSTRING to return a Z|WSTRING
+- SWAP statement will accept UDT as Z|WSTRING
+- IIF function will accept UDT as Z|WSTRING
 
 [fixed]
 - sf.net #881: C backend: support for varadic function parameters in gcc using __builtin_va_list type and related macros

src/compiler/ast-node-conv.bas

@@ -285,7 +285,7 @@ end function
 		proc = symbFindCastOvlProc( to_dtype, to_subtype, node, @err_num )
 		if( proc <> NULL ) then
 			'' build a proc call
-			return astBuildCall( proc, l )
+			return astBuildCall( proc, node )
 		else
 			if( err_num <> FB_ERRMSG_OK ) then
 				return NULL
@@ -294,6 +294,43 @@ end function
 	end scope
 #endmacro
 
+'':::::
+function astTryOvlStringCONV( byref expr as ASTNODE ptr ) as integer
+
+	dim as FBSYMBOL ptr proc = any, sym = any
+	dim as FB_ERRMSG err_num = any
+	dim as integer dtype = any
+
+	assert( expr )
+
+	if( astGetDataType( expr ) = FB_DATATYPE_STRUCT ) then
+		sym = astGetSubType( expr )
+
+		if( symbGetUdtIsZstring( sym ) ) then
+			dtype = FB_DATATYPE_CHAR
+		elseif( symbGetUdtIsWstring( sym ) ) then
+			dtype = FB_DATATYPE_WCHAR
+		else
+			dtype = FB_DATATYPE_VOID
+		end if
+
+		if( dtype <> FB_DATATYPE_VOID ) then
+			'' can cast to z|wstring?
+			proc = symbFindCastOvlProc( dtype, NULL, expr, @err_num )
+			if( proc ) then
+				'' same type?
+				if( symbGetType( proc ) = dtype ) then
+					expr = astBuildCall( proc, expr )
+					return TRUE
+				end if
+			end if
+		end if
+	end if
+
+	return FALSE
+
+end function
+
 '':::::
 function astNewCONV _
 	( _
@@ -349,6 +386,44 @@ function astNewCONV _
 		end if
 	end if
 
+	'' UDT? check if it is z|wstring? 
+	'' !!! TODO !!! make this block in to a function
+	''              re-use in astNewOvlCONV()
+	''              rewrite hDoGlobOpOverload() as astTry* function
+	if( typeGet( ldtype ) = FB_DATATYPE_STRUCT ) then
+		dim as FBSYMBOL ptr subtype = astGetSubtype( l )
+
+		if( symbGetUdtIsZstring( subtype ) or symbGetUdtIsWstring( subtype ) ) then
+			dim as FBSYMBOL ptr proc = NULL
+			dim as FB_ERRMSG err_num = any
+
+			'' check exact casts
+			proc = symbFindCastOvlProc( to_dtype, to_subtype, l, @err_num, TRUE )
+			if( proc <> NULL ) then
+				'' build a proc call
+				return astBuildCall( proc, l )
+			end if
+
+			'' check exact string pointer casts
+			if( symbGetUdtIsZstring( subtype ) ) then
+				proc = symbFindCastOvlProc( typeAddrof( FB_DATATYPE_CHAR ), NULL, l, @err_num, TRUE )
+			elseif( symbGetUdtIsWstring( subtype ) ) then
+				proc = symbFindCastOvlProc( typeAddrof( FB_DATATYPE_WCHAR ), NULL, l, @err_num, TRUE )
+			end if
+			if( proc <> NULL ) then
+				'' build a proc call
+				return astBuildCall( proc, l )
+			end if
+
+			'' strings? convert.
+			if( options and AST_CONVOPT_CHECKSTR ) then
+				if( astTryOvlStringCONV( l ) ) then
+					ldtype = astGetFullType( l )
+				end if
+			end if
+		end if
+	end if
+
 	'' try casting op overloading
 	hDoGlobOpOverload( to_dtype, to_subtype, l )
 

src/compiler/ast-node-iif.bas

@@ -199,6 +199,35 @@ function astNewIIF _
 	dtype = FB_DATATYPE_INVALID
 	subtype = NULL
 
+	'' Maybe UDT extends Z|WSTRING? Check for string conversions...
+	if( truexpr->dtype <> falsexpr->dtype ) then
+		if( truexpr->dtype = FB_DATATYPE_STRUCT ) then
+			if( symbGetUdtIsZstring( truexpr->subtype ) ) then
+				if( falsexpr->dtype = FB_DATATYPE_CHAR ) then
+					astTryOvlStringCONV( truexpr )
+					truexpr->dtype = astGetDataType( truexpr )
+				end if
+			elseif( symbGetUdtIsWstring( truexpr->subtype ) ) then
+				if( falsexpr->dtype = FB_DATATYPE_WCHAR ) then
+					astTryOvlStringCONV( truexpr )
+					truexpr->dtype = astGetDataType( truexpr )
+				end if
+			end if
+		elseif( falsexpr->dtype = FB_DATATYPE_STRUCT ) then
+			if( symbGetUdtIsZstring( falsexpr->subtype ) ) then
+				if( truexpr->dtype = FB_DATATYPE_CHAR ) then
+					astTryOvlStringCONV( falsexpr )
+					falsexpr->dtype = astGetDataType( falsexpr )
+				end if
+			elseif( symbGetUdtIsWstring( falsexpr->subtype ) ) then
+				if( truexpr->dtype = FB_DATATYPE_WCHAR ) then
+					astTryOvlStringCONV( falsexpr )
+					falsexpr->dtype = astGetDataType( falsexpr )
+				end if
+			end if
+		end if
+	end if
+
 	'' check types & find the iif() result type
 	if( hCheckTypes( truexpr->dtype, truexpr->subtype, _
 	                 falsexpr->dtype, falsexpr->subtype, _

src/compiler/ast.bi

@@ -536,6 +536,8 @@ enum AST_CONVOPT
 	AST_CONVOPT_DONTWARNFUNCPTR = &h20
 end enum
 
+declare function astTryOvlStringCONV( byref expr as ASTNODE ptr ) as integer
+
 declare function astNewCONV _
 	( _
 		byval to_dtype as integer, _

src/compiler/parser-compound-select.bas

@@ -92,6 +92,8 @@ sub cSelectStmtBegin( )
 		expr = astNewCONSTi( 0 )
 	end if
 
+	astTryOvlStringCONV( expr )
+
 	'' can't be an UDT
 	if( astGetDataType( expr ) = FB_DATATYPE_STRUCT ) then
 		errReport( FB_ERRMSG_INVALIDDATATYPES )

src/compiler/parser-decl-struct.bas

@@ -626,7 +626,9 @@ private function hTypeAdd _
 		byval id_alias as zstring ptr, _
 		byval isunion as integer, _
 		byval align as integer, _
-		byval baseSubtype as FBSYMBOL ptr = NULL _
+		byval baseDType as integer = 0, _
+		byval baseSubtype as FBSYMBOL ptr = NULL, _
+		byval baseStringType as integer = 0 _
 	) as FBSYMBOL ptr
 
 	dim as FBSYMBOL ptr s = any
@@ -638,6 +640,13 @@ private function hTypeAdd _
 		s = symbStructBegin( NULL, NULL, parent, symbUniqueLabel( ), NULL, isunion, align, (baseSubtype <> NULL), 0, 0 )
 	end if
 
+	select case baseStringType
+	case FB_DATATYPE_CHAR
+		symbSetUdtIsZstring( s )
+	case FB_DATATYPE_WCHAR
+		symbSetUdtIsWstring( s )
+	end select
+
 	if( baseSubtype ) then
 		symbStructAddBase( s, baseSubtype )
 	end if
@@ -998,18 +1007,75 @@ sub cTypeDecl( byval attrib as integer )
 
 	'' (EXTENDS SymbolType)?
 	dim as FBSYMBOL ptr baseSubtype = NULL
+	dim as integer baseDType = 0
+	dim as integer stringType = 0
+
 	if( lexGetToken( ) = FB_TK_EXTENDS ) then
 		lexSkipToken( )
 
 		'' SymbolType
-		dim as integer baseDtype
-		hSymbolType( baseDtype, baseSubtype, 0 )
+		hSymbolType( baseDType, baseSubtype, 0, FALSE, TRUE )
 
 		'' is the base type a struct?
 		if( baseDType <> FB_DATATYPE_STRUCT ) then
-			errReport( FB_ERRMSG_EXPECTEDCLASSTYPE )
-			'' error recovery: skip
-			baseSubtype = NULL
+			
+			'' allow extending WSTRING and ZSTRING, the UDT
+			'' will use different rules for conversions,
+			if (baseDType = FB_DATATYPE_WCHAR) or (baseDType = FB_DATATYPE_CHAR) then
+				stringType = baseDType
+				baseDType = 0
+				assert( baseSubtype = NULL )
+
+			'' anything else? don't allow
+			else
+				errReport( FB_ERRMSG_EXPECTEDCLASSTYPE )
+				'' error recovery: skip
+				baseSubtype = NULL
+			end if
+		end if
+
+		'' got a string type?  check for another base type
+		if( stringType <> 0 ) then
+
+			'' ','?
+			if( lexGetToken( ) = CHAR_COMMA ) then
+				lexSkipToken( )
+
+				'' SymbolType
+				hSymbolType( baseDType, baseSubtype, 0, FALSE, TRUE )
+
+				'' is the base type a struct?
+				if( baseDType <> FB_DATATYPE_STRUCT ) then
+					errReport( FB_ERRMSG_EXPECTEDCLASSTYPE )
+					'' error recovery: skip
+					baseSubtype = NULL
+				end if
+			end if
+		end if
+
+		'' base type? check if z|wstring was already extended
+		if( baseSubType ) then
+			select case stringType
+			case FB_DATATYPE_CHAR
+				'' can't extend zstring if inheriting from wstring
+				if( symbGetUdtIsWstring( baseSubtype ) ) then
+					errReport( FB_ERRMSG_INVALIDDATATYPES )
+					stringType = FB_DATATYPE_WCHAR
+				end if
+			case FB_DATATYPE_WCHAR
+				'' can't extend wstring if inheriting from zstring
+				if( symbGetUdtIsZstring( baseSubtype ) ) then
+					errReport( FB_ERRMSG_INVALIDDATATYPES )
+					stringType = FB_DATATYPE_CHAR
+				end if
+			case else
+				'' inherit from base type
+				if( symbGetUdtIsZstring( baseSubtype ) ) then
+					stringType = FB_DATATYPE_CHAR
+				elseif( symbGetUdtIsWstring( baseSubtype ) ) then
+					stringType = FB_DATATYPE_WCHAR
+				end if
+			end select
 		end if
 	end if
 
@@ -1029,7 +1095,7 @@ sub cTypeDecl( byval attrib as integer )
 	dim as FBSYMBOL ptr currprocsym = parser.currproc, currblocksym = parser.currblock
 	dim as integer scope_depth = parser.scope
 
-	sym = hTypeAdd( NULL, id, palias, isunion, align, baseSubtype )
+	sym = hTypeAdd( NULL, id, palias, isunion, align, baseDType, baseSubtype, stringType )
 
 	'' restore the context
 	ast.proc.curr = currproc

src/compiler/parser-decl-var.bas

@@ -38,14 +38,18 @@ sub hSymbolType _
 		byref dtype as integer, _
 		byref subtype as FBSYMBOL ptr, _
 		byref lgt as longint, _
-		byval is_byref as integer _
+		byval is_byref as integer, _
+		byval is_extends as integer _
 	)
 
 	dim as integer options = FB_SYMBTYPEOPT_DEFAULT
 	if( is_byref ) then
 		options and= not FB_SYMBTYPEOPT_CHECKSTRPTR
 		options or= FB_SYMBTYPEOPT_ISBYREF
 	end if
+	if( is_extends ) then
+		options and= not FB_SYMBTYPEOPT_CHECKSTRPTR
+	end if
 
 	'' parse the symbol type (INTEGER, STRING, etc...)
 	if( cSymbolType( dtype, subtype, lgt, , options ) = FALSE ) then

src/compiler/parser-expr-unary.bas

@@ -655,6 +655,15 @@ function cAddrOfExpression( ) as ASTNODE ptr
 
 		dim as integer dtype = astGetDataType( expr )
 
+		'' UDT? it might be a kind of z|wstring
+		if( typeGet( dtype ) = FB_DATATYPE_STRUCT ) then
+			var sym = astGetSubType( expr )
+			if( symbGetUdtIsZstring( sym ) or symbGetUdtIsWstring( sym ) ) then
+				astTryOvlStringCONV( expr )
+				dtype = astGetDataType( expr )
+			end if
+		end if
+
 		if( symbIsString( dtype ) = FALSE ) then
 			errReport( FB_ERRMSG_INVALIDDATATYPES )
 			'' error recovery: skip until ')' and fake a node
@@ -678,15 +687,21 @@ function cAddrOfExpression( ) as ASTNODE ptr
 		end select
 
 		'' varlen? do: *cast( [const] zstring const ptr ptr, @expr )
-		if( dtype = FB_DATATYPE_STRING ) then
+		select case dtype
+		case FB_DATATYPE_STRING
 			expr = astBuildStrPtr( expr )
 
+		case FB_DATATYPE_WCHAR
+			expr = astNewCONV( typeAddrOf( FB_DATATYPE_WCHAR ), _
+							   NULL, _
+							   astNewADDROF( expr ) )
+
 		'' anything else: do cast( zstring ptr, @expr )
-		else
+		case else
 			expr = astNewCONV( typeAddrOf( FB_DATATYPE_CHAR ), _
 							   NULL, _
 							   astNewADDROF( expr ) )
-		end if
+		end select
 
 		'' ')'
 		if( hMatch( CHAR_RPRNT ) = FALSE ) then

src/compiler/parser-quirk-array.bas

@@ -84,6 +84,37 @@ private function hScopedSwap( ) as integer
 	dim as integer ldtype = astGetDataType( l )
 	dim as integer rdtype = astGetDataType( r )
 
+	'' Maybe UDT extends Z|WSTRING? Check for string conversions...
+	if( ldtype <> rdtype ) then
+		if( ldtype = FB_DATATYPE_STRUCT ) then
+			var sym = astGetSubType( l )
+			if( symbGetUdtIsZstring( sym ) ) then
+				if( rdtype = FB_DATATYPE_CHAR ) then
+					astTryOvlStringCONV( l )
+					ldtype = astGetDataType( l )
+				end if
+			elseif( symbGetUdtIsWstring( sym ) ) then
+				if( rdtype = FB_DATATYPE_WCHAR ) then
+					astTryOvlStringCONV( l )
+					ldtype = astGetDataType( l )
+				end if
+			end if
+		elseif( rdtype = FB_DATATYPE_STRUCT ) then
+			var sym = astGetSubType( r )
+			if( symbGetUdtIsZstring( sym ) ) then
+				if( ldtype = FB_DATATYPE_CHAR ) then
+					astTryOvlStringCONV( r )
+					rdtype = astGetDataType( r )
+				end if
+			elseif( symbGetUdtIsWstring( sym ) ) then
+				if( ldtype = FB_DATATYPE_WCHAR ) then
+					astTryOvlStringCONV( r )
+					rdtype = astGetDataType( r )
+				end if
+			end if
+		end if
+	end if
+
 	select case( ldtype )
 	case FB_DATATYPE_STRING, FB_DATATYPE_FIXSTR, FB_DATATYPE_CHAR
 		select case rdtype