"Fossies" - the Fresh Open Source Software Archive

Member "FreeBASIC-1.07.1-source/src/compiler/ast-node-conv.bas" (27 Sep 2019, 20330 Bytes) of package /linux/privat/FreeBASIC-1.07.1-source.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Visual Basic source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "ast-node-conv.bas": 1.07.0_vs_1.07.1.

    1 '' AST conversion nodes
    2 '' l = expression to convert; r = NULL
    3 ''
    4 '' chng: sep/2004 written [v1ctor]
    5 
    6 #include once "fb.bi"
    7 #include once "fbint.bi"
    8 #include once "ir.bi"
    9 #include once "rtl.bi"
   10 #include once "ast.bi"
   11 
   12 private sub hConstConv( byval todtype as integer, byval l as ASTNODE ptr )
   13     dim as integer ldtype = any
   14 
   15     ldtype = astGetFullType( l )
   16 
   17     if( typeGetClass( ldtype ) = FB_DATACLASS_FPOINT ) then
   18         select case as const( typeGetSizeType( todtype ) )
   19         case FB_SIZETYPE_FLOAT32
   20             '' SINGLE -> SINGLE: nothing to do
   21             '' DOUBLE -> SINGLE?
   22             if( typeGetDtAndPtrOnly( ldtype ) = FB_DATATYPE_DOUBLE ) then
   23                 '' Truncate DOUBLE to SINGLE (note: csng()
   24                 '' before 0.25 didn't truncate in this case,
   25                 '' so using an explicit temp var instead)
   26                 dim as single f = any
   27                 f = l->val.f
   28                 l->val.f = f
   29             end if
   30         case FB_SIZETYPE_FLOAT64
   31             '' SINGLE/DOUBLE -> DOUBLE:
   32             '' Nothing to do, since float constants are stored as DOUBLE
   33         case FB_SIZETYPE_BOOLEAN
   34             l->val.i = cbool( l->val.f )
   35         case FB_SIZETYPE_INT8
   36             l->val.i = cbyte( l->val.f )
   37         case FB_SIZETYPE_UINT8
   38             l->val.i = cubyte( l->val.f )
   39         case FB_SIZETYPE_INT16
   40             l->val.i = cshort( l->val.f )
   41         case FB_SIZETYPE_UINT16
   42             l->val.i = cushort( l->val.f )
   43         case FB_SIZETYPE_INT32
   44             l->val.i = clng( l->val.f )
   45         case FB_SIZETYPE_UINT32
   46             l->val.i = culng( l->val.f )
   47         case FB_SIZETYPE_INT64
   48             l->val.i = clngint( l->val.f )
   49         case FB_SIZETYPE_UINT64
   50             l->val.i = hCastFloatToULongint( l->val.f )
   51         end select
   52     elseif( typeIsSigned( ldtype ) ) then
   53         select case as const( typeGetSizeType( todtype ) )
   54         case FB_SIZETYPE_FLOAT32
   55             l->val.f = csng( l->val.i )
   56         case FB_SIZETYPE_FLOAT64
   57             l->val.f = cdbl( l->val.i )
   58         case FB_SIZETYPE_BOOLEAN
   59             l->val.i = cbool( l->val.i )
   60         case FB_SIZETYPE_INT8
   61             l->val.i = cbyte( l->val.i )
   62         case FB_SIZETYPE_UINT8
   63             l->val.i = cubyte( l->val.i )
   64         case FB_SIZETYPE_INT16
   65             l->val.i = cshort( l->val.i )
   66         case FB_SIZETYPE_UINT16
   67             l->val.i = cushort( l->val.i )
   68         case FB_SIZETYPE_INT32
   69             l->val.i = clng( l->val.i )
   70         case FB_SIZETYPE_UINT32
   71             l->val.i = culng( l->val.i )
   72         case FB_SIZETYPE_INT64
   73             l->val.i = clngint( l->val.i )
   74         case FB_SIZETYPE_UINT64
   75             l->val.i = culngint( l->val.i )
   76         end select
   77     else
   78         select case as const( typeGetSizeType( todtype ) )
   79         case FB_SIZETYPE_FLOAT32
   80             l->val.f = csng( cunsg( l->val.i ) )
   81         case FB_SIZETYPE_FLOAT64
   82             l->val.f = cdbl( cunsg( l->val.i ) )
   83         case FB_SIZETYPE_BOOLEAN
   84             l->val.i = cbool( cunsg( l->val.i ) )
   85         case FB_SIZETYPE_INT8
   86             l->val.i = cbyte( cunsg( l->val.i ) )
   87         case FB_SIZETYPE_UINT8
   88             l->val.i = cubyte( cunsg( l->val.i ) )
   89         case FB_SIZETYPE_INT16
   90             l->val.i = cshort( cunsg( l->val.i ) )
   91         case FB_SIZETYPE_UINT16
   92             l->val.i = cushort( cunsg( l->val.i ) )
   93         case FB_SIZETYPE_INT32
   94             l->val.i = clng( cunsg( l->val.i ) )
   95         case FB_SIZETYPE_UINT32
   96             l->val.i = culng( cunsg( l->val.i ) )
   97         case FB_SIZETYPE_INT64
   98             l->val.i = clngint( cunsg( l->val.i ) )
   99         case FB_SIZETYPE_UINT64
  100             l->val.i = culngint( cunsg( l->val.i ) )
  101         end select
  102     end if
  103 end sub
  104 
  105 '':::::
  106 private function hGetTypeMismatchErrMsg( byval options as AST_CONVOPT ) as integer
  107     if( options and AST_CONVOPT_PTRONLY ) then
  108         function = FB_ERRMSG_EXPECTEDPOINTER
  109     else
  110         function = FB_ERRMSG_TYPEMISMATCH
  111     end if
  112 end function
  113 
  114 function astCheckConvNonPtrToPtr _
  115     ( _
  116         byval to_dtype as integer, _
  117         byval expr_dtype as integer, _
  118         byval expr as ASTNODE ptr, _
  119         byval options as AST_CONVOPT _
  120     ) as integer
  121 
  122     assert( typeIsPtr( to_dtype ) )
  123     assert( typeIsPtr( expr_dtype ) = FALSE )
  124 
  125     if( typeGetClass( expr_dtype ) = FB_DATACLASS_INTEGER ) then
  126         '' Allow converting literal 0 with any integer type to any pointer type
  127         if( astIsCONST( expr ) ) then
  128             if( astConstEqZero( expr ) ) then
  129                 return FB_ERRMSG_OK
  130             end if
  131         end if
  132 
  133         '' Allow integer-to-pointer casts only if same size
  134         if( typeGetSize( expr_dtype ) = env.pointersize ) then
  135             return FB_ERRMSG_OK
  136         end if
  137     end if
  138 
  139     function = hGetTypeMismatchErrMsg( options )
  140 end function
  141 
  142 private function hCheckPtr _
  143     ( _
  144         byval to_dtype as integer, _
  145         byval to_subtype as FBSYMBOL ptr, _
  146         byval expr_dtype as integer, _
  147         byval expr as ASTNODE ptr, _
  148         byval options as AST_CONVOPT _
  149     ) as integer
  150 
  151     function = FB_ERRMSG_OK
  152 
  153     '' to pointer? only allow integers of same size, and pointers
  154     if( typeIsPtr( to_dtype ) ) then
  155         if( typeIsPtr( expr_dtype ) = FALSE ) then
  156             return astCheckConvNonPtrToPtr( to_dtype, expr_dtype, expr, options )
  157         end if
  158 
  159         '' Both are pointers, fall through to checks below
  160 
  161     '' from pointer? only allow integers of same size and pointers
  162     elseif( typeIsPtr( expr_dtype ) ) then
  163         if( typeGetClass( to_dtype ) = FB_DATACLASS_INTEGER ) then
  164             '' Allow converting literal 0 with any pointer type to any integer type
  165             if( astIsCONST( expr ) ) then
  166                 if( astConstEqZero( expr ) ) then
  167                     exit function
  168                 end if
  169             end if
  170 
  171             '' Allow pointer-to-integer casts if same size
  172             if( typeGetSize( to_dtype ) = env.pointersize ) then
  173                 exit function
  174             end if
  175         end if
  176 
  177         return hGetTypeMismatchErrMsg( options )
  178     else
  179         '' No pointers at all, nothing to do
  180         exit function
  181     end if
  182 
  183     ''
  184     '' Both are pointers
  185     ''
  186     '' If any of them is a pointer to a derived class,
  187     '' only allow casting to a pointer to a class from that
  188     '' inheritance hierarchy, or ANY PTR.
  189     ''
  190 
  191     '' To derived pointer?
  192     if( typeGetDtOnly( to_dtype ) = FB_DATATYPE_STRUCT ) then
  193         if( to_subtype->udt.base <> NULL ) then
  194             if( typeGetDtOnly( expr_dtype ) <> FB_DATATYPE_STRUCT ) then
  195                 if( typeGetDtOnly( expr_dtype ) <> FB_DATATYPE_VOID ) then
  196                     return FB_ERRMSG_CASTDERIVEDPTRFROMINCOMPATIBLE
  197                 end if
  198             else            
  199                 '' not a upcasting?
  200                 if( symbGetUDTBaseLevel( expr->subtype, to_subtype ) = 0 ) then
  201                     '' try downcasting..
  202                     if( symbGetUDTBaseLevel( to_subtype, expr->subtype ) = 0 ) then
  203                         return FB_ERRMSG_CASTDERIVEDPTRFROMUNRELATED
  204                     End If
  205                 End If
  206             end if
  207         End If
  208     End If
  209 
  210     '' From derived pointer?
  211     if( typeGetDtOnly( expr_dtype ) = FB_DATATYPE_STRUCT ) then     
  212         if( expr->subtype->udt.base <> NULL ) then
  213             if( typeGetDtOnly( to_dtype ) <> FB_DATATYPE_STRUCT ) then
  214                 if( typeGetDtOnly( to_dtype ) <> FB_DATATYPE_VOID ) then
  215                     return FB_ERRMSG_CASTDERIVEDPTRTOINCOMPATIBLE
  216                 end if
  217             else
  218                 '' not a upcasting?
  219                 if( symbGetUDTBaseLevel( to_subtype, expr->subtype ) = 0 ) then
  220                     '' try downcasting..
  221                     if( symbGetUDTBaseLevel( expr->subtype, to_subtype ) = 0 ) then
  222                         return FB_ERRMSG_CASTDERIVEDPTRTOUNRELATED
  223                     End If
  224                 End If
  225             end if
  226         End If
  227     End If
  228 
  229 end function
  230 
  231 '':::::
  232 function astCheckCONV _
  233     ( _
  234         byval to_dtype as integer, _
  235         byval to_subtype as FBSYMBOL ptr, _
  236         byval l as ASTNODE ptr _
  237     ) as integer
  238 
  239     dim as integer ldtype = any
  240 
  241     function = FALSE
  242 
  243     ldtype = astGetFullType( l )
  244 
  245     '' to or from UDT? only upcasting supported by now
  246     if( (typeGet( to_dtype ) = FB_DATATYPE_STRUCT) or _
  247         (typeGet( ldtype   ) = FB_DATATYPE_STRUCT)      ) then
  248         if( (typeGet( to_dtype ) = FB_DATATYPE_STRUCT) and _
  249             (typeGet( ldtype   ) = FB_DATATYPE_STRUCT)      ) then
  250             function = (symbGetUDTBaseLevel( l->subtype, to_subtype ) > 0)
  251         end if
  252         exit function
  253     end if
  254 
  255     '' string? neither
  256     if( typeGetClass( ldtype ) = FB_DATACLASS_STRING ) then
  257         exit function
  258     end if
  259 
  260     '' check pointers
  261     if( hCheckPtr( to_dtype, to_subtype, ldtype, l, 0 ) <> FB_ERRMSG_OK ) then
  262         exit function
  263     end if
  264 
  265     select case typeGet( ldtype )
  266     '' CHAR and WCHAR literals are also from the INTEGER class
  267     case FB_DATATYPE_CHAR, FB_DATATYPE_WCHAR
  268         '' don't allow, unless it's a deref pointer
  269         if( astIsDEREF( l ) = FALSE ) then
  270             exit function
  271         end if
  272 
  273     end select
  274 
  275     function = TRUE
  276 
  277 end function
  278 
  279 '':::::
  280 #macro hDoGlobOpOverload( to_dtype, to_subtype, node )
  281     scope
  282         dim as FBSYMBOL ptr proc = any
  283         dim as FB_ERRMSG err_num = any
  284 
  285         proc = symbFindCastOvlProc( to_dtype, to_subtype, node, @err_num )
  286         if( proc <> NULL ) then
  287             '' build a proc call
  288             return astBuildCall( proc, node )
  289         else
  290             if( err_num <> FB_ERRMSG_OK ) then
  291                 return NULL
  292             end if
  293         end if
  294     end scope
  295 #endmacro
  296 
  297 '':::::
  298 function astTryOvlStringCONV( byref expr as ASTNODE ptr ) as integer
  299 
  300     dim as FBSYMBOL ptr proc = any, sym = any
  301     dim as FB_ERRMSG err_num = any
  302     dim as integer dtype = any
  303 
  304     assert( expr )
  305 
  306     if( astGetDataType( expr ) = FB_DATATYPE_STRUCT ) then
  307         sym = astGetSubType( expr )
  308 
  309         if( symbGetUdtIsZstring( sym ) ) then
  310             dtype = FB_DATATYPE_CHAR
  311         elseif( symbGetUdtIsWstring( sym ) ) then
  312             dtype = FB_DATATYPE_WCHAR
  313         else
  314             dtype = FB_DATATYPE_VOID
  315         end if
  316 
  317         if( dtype <> FB_DATATYPE_VOID ) then
  318             '' can cast to z|wstring?
  319             proc = symbFindCastOvlProc( dtype, NULL, expr, @err_num )
  320             if( proc ) then
  321                 '' same type?
  322                 if( symbGetType( proc ) = dtype ) then
  323                     expr = astBuildCall( proc, expr )
  324                     return TRUE
  325                 end if
  326             end if
  327         end if
  328     end if
  329 
  330     return FALSE
  331 
  332 end function
  333 
  334 '':::::
  335 function astNewCONV _
  336     ( _
  337         byval to_dtype as integer, _
  338         byval to_subtype as FBSYMBOL ptr, _
  339         byval l as ASTNODE ptr, _
  340         byval options as AST_CONVOPT, _
  341         byval perrmsg as integer ptr _
  342     ) as ASTNODE ptr
  343 
  344     dim as ASTNODE ptr n = any
  345     dim as integer ldclass = any, ldtype = any, errmsg = any, wrnmsg = any, doconv = any
  346 
  347     if( perrmsg ) then
  348         *perrmsg = FB_ERRMSG_OK
  349     end if
  350 
  351     ldtype = astGetFullType( l )
  352 
  353     '' same type?
  354     if( typeGetDtAndPtrOnly( ldtype ) = typeGetDtAndPtrOnly( to_dtype ) ) then
  355         if( l->subtype = to_subtype ) then
  356             '' Only CONST bits changed?
  357             if( typeGetConstMask( ldtype ) <> typeGetConstMask( to_dtype ) ) then
  358                 '' CONST node? Evaluate at compile-time
  359                 if( astIsCONST( l ) ) then
  360                     astSetType( l, to_dtype, to_subtype )
  361                     n = l
  362                 else
  363                     '' Otherwise, add a CONV node to represent the changed CONST bits
  364                     '' to the expression parser
  365                     n = astNewNode( AST_NODECLASS_CONV, to_dtype, to_subtype )
  366                     n->l = l
  367 
  368                     n->cast.doconv = FALSE
  369                     n->cast.do_convfd2fs = FALSE
  370                     
  371                     '' data types and levels of pointer inderection are the same,
  372                     '' always record this as const conversion
  373                     n->cast.convconst = TRUE
  374 
  375                     if( (options and AST_CONVOPT_DONTWARNCONST) = 0 ) then
  376                         if( fbPdCheckIsSet( FB_PDCHECK_CONSTNESS ) ) then
  377                             errReportWarn( FB_WARNINGMSG_CONSTQUALIFIERDISCARDED )
  378                         end if
  379                     end if
  380                 end if
  381             else
  382                 n = l
  383             end if
  384 
  385             return n
  386         end if
  387     end if
  388 
  389     '' UDT? check if it is z|wstring? 
  390     '' !!! TODO !!! make this block in to a function
  391     ''              re-use in astNewOvlCONV()
  392     ''              rewrite hDoGlobOpOverload() as astTry* function
  393     if( typeGet( ldtype ) = FB_DATATYPE_STRUCT ) then
  394         dim as FBSYMBOL ptr subtype = astGetSubtype( l )
  395 
  396         if( symbGetUdtIsZstring( subtype ) or symbGetUdtIsWstring( subtype ) ) then
  397             dim as FBSYMBOL ptr proc = NULL
  398             dim as FB_ERRMSG err_num = any
  399 
  400             '' check exact casts
  401             proc = symbFindCastOvlProc( to_dtype, to_subtype, l, @err_num, TRUE )
  402             if( proc <> NULL ) then
  403                 '' build a proc call
  404                 return astBuildCall( proc, l )
  405             end if
  406 
  407             '' check exact string pointer casts
  408             if( symbGetUdtIsZstring( subtype ) ) then
  409                 proc = symbFindCastOvlProc( typeAddrof( FB_DATATYPE_CHAR ), NULL, l, @err_num, TRUE )
  410             elseif( symbGetUdtIsWstring( subtype ) ) then
  411                 proc = symbFindCastOvlProc( typeAddrof( FB_DATATYPE_WCHAR ), NULL, l, @err_num, TRUE )
  412             end if
  413             if( proc <> NULL ) then
  414                 '' build a proc call
  415                 return astBuildCall( proc, l )
  416             end if
  417 
  418             '' strings? convert.
  419             if( options and AST_CONVOPT_CHECKSTR ) then
  420                 if( astTryOvlStringCONV( l ) ) then
  421                     ldtype = astGetFullType( l )
  422                 end if
  423             end if
  424         end if
  425     end if
  426 
  427     '' try casting op overloading
  428     hDoGlobOpOverload( to_dtype, to_subtype, l )
  429 
  430     select case as const typeGet( to_dtype )
  431     case FB_DATATYPE_VOID, FB_DATATYPE_STRING, FB_DATATYPE_FIXSTR, _
  432          FB_DATATYPE_CHAR, FB_DATATYPE_WCHAR
  433         '' refuse void (used by uop/bop to cast to be most precise
  434         '' possible) and strings, as op overloading already failed
  435         exit function
  436 
  437     '' to UDT?
  438     case FB_DATATYPE_STRUCT ', FB_DATATYPE_CLASS
  439         '' not from UDT? op overloading already failed, refuse.
  440         if( typeGet( ldtype ) <> FB_DATATYPE_STRUCT ) then
  441             exit function
  442         end if
  443 
  444         if( symbGetUDTBaseLevel( l->subtype, to_subtype ) = 0 ) then
  445             exit function
  446         end if
  447 
  448     '' to anything else (integers/floats)
  449     case else
  450         '' from UDT? refuse, since op overloading already failed
  451         if( typeGet( ldtype ) = FB_DATATYPE_STRUCT ) then
  452             exit function
  453         end if
  454 
  455     end select
  456 
  457     ldclass = typeGetClass( ldtype )
  458 
  459     '' sign conversion?
  460     if( options and AST_CONVOPT_SIGNCONV ) then
  461         '' float? invalid
  462         if( ldclass <> FB_DATACLASS_INTEGER ) then
  463             exit function
  464         end if
  465     end if
  466 
  467     if( (options and AST_CONVOPT_DONTCHKPTR) = 0 ) then
  468         '' check pointers
  469         errmsg = hCheckPtr( to_dtype, to_subtype, ldtype, l, options )
  470         if( errmsg <> FB_ERRMSG_OK ) then
  471             if( perrmsg ) then
  472                 *perrmsg = errmsg
  473             end if
  474             exit function
  475         end if
  476     end if
  477 
  478     '' string?
  479     if( options and AST_CONVOPT_CHECKSTR ) then
  480         select case as const typeGet( ldtype )
  481         case FB_DATATYPE_STRING, FB_DATATYPE_FIXSTR, _
  482              FB_DATATYPE_CHAR, FB_DATATYPE_WCHAR
  483             return rtlStrToVal( l, to_dtype )
  484         end select
  485     else
  486         if( ldclass = FB_DATACLASS_STRING ) then
  487             exit function
  488         '' CHAR and WCHAR literals are also from the INTEGER class
  489         else
  490             select case typeGet( ldtype )
  491             case FB_DATATYPE_CHAR, FB_DATATYPE_WCHAR
  492                 '' don't allow, unless it's a deref pointer
  493                 if( astIsDEREF( l ) = FALSE ) then
  494                     exit function
  495                 end if
  496             end select
  497         end if
  498     end if
  499 
  500     '' constant? evaluate at compile-time
  501     if( astIsCONST( l ) ) then
  502         astCheckConst( to_dtype, l )
  503 
  504         hConstConv( to_dtype, l )
  505 
  506         l->dtype = to_dtype
  507         l->subtype = to_subtype
  508         return l
  509     end if
  510 
  511     doconv = TRUE
  512 
  513     '' only convert if the classes are different (ie, floating<->integer) or
  514     '' if sizes are different (ie, byte<->int)
  515     '' or one is a boolean and the other is not boolean
  516     if( ldclass = typeGetClass( to_dtype ) ) then
  517         select case( typeGet( to_dtype ) )
  518         case FB_DATATYPE_STRUCT '', FB_DATATYPE_CLASS
  519             '' do nothing
  520             doconv = FALSE
  521         case else
  522             if( (ldtype = FB_DATATYPE_BOOLEAN) or (to_dtype = FB_DATATYPE_BOOLEAN) ) then
  523                 if( ldtype = to_dtype ) then
  524                     doconv = FALSE
  525                 end if
  526             else
  527                 if( typeGetSize( ldtype ) = typeGetSize( to_dtype ) ) then
  528                     doconv = FALSE
  529                 end if
  530             end if
  531         end select
  532     end if
  533 
  534     if( irGetOption( IR_OPT_FPUCONV ) ) then
  535         if (ldclass = FB_DATACLASS_FPOINT) and ( typeGetClass( to_dtype ) = FB_DATACLASS_FPOINT ) then
  536             if( typeGetSize( ldtype ) <> typeGetSize( to_dtype ) ) then
  537                 doconv = TRUE
  538             end if
  539         end if
  540     end if
  541 
  542     '' casting another cast?
  543     if( l->class = AST_NODECLASS_CONV ) then
  544         '' no conversion in both?
  545         if( l->cast.doconv = FALSE ) then
  546             if( doconv = FALSE ) then
  547                 '' just replace the bottom cast()'s type
  548                 astGetFullType( l ) = to_dtype
  549                 l->subtype = to_subtype
  550                 return l
  551             end if
  552         end if
  553     end if
  554 
  555     '' alloc new node
  556     n = astNewNode( AST_NODECLASS_CONV, to_dtype, to_subtype )
  557 
  558     n->l = l
  559     n->cast.doconv = doconv
  560     n->cast.do_convfd2fs = FALSE
  561     n->cast.convconst = FALSE
  562 
  563     '' Discarding/changing const qualifier bits ?
  564     if( typeIsPtr( ldtype ) and typeIsPtr( to_dtype ) ) then
  565 
  566         wrnmsg = 0
  567 
  568         n->cast.convconst = ( symbCheckConstAssign( to_dtype, ldtype, to_subtype, l->subtype, , , wrnmsg ) = FALSE )
  569 
  570         '' -w funcptr  -w constness
  571         ''    no           no          don't warn anything         
  572         ''    yes          yes         warn everything
  573         ''    yes          no          warn if wrnmsg<>0
  574         ''    no           yes         warn everything (-w constness implies -w funcptr)
  575 
  576         '' else check if const conversion
  577         if( n->cast.convconst ) then
  578 
  579             '' wrnmsg is <> 0 only if funcptr check failed
  580             '' specific warning message takes priority over const warning
  581             if( wrnmsg <> 0 ) then
  582                 if( (options and AST_CONVOPT_DONTWARNFUNCPTR) = 0 ) then
  583                     errReportWarn( wrnmsg, , , strptr(" in function pointer") )
  584                 end if
  585 
  586             '' else, must be const warning
  587             else
  588 
  589                 if( (options and AST_CONVOPT_DONTWARNCONST) = 0 ) then
  590                     if( fbPdCheckIsSet( FB_PDCHECK_CONSTNESS ) ) then
  591                         errReportWarn( FB_WARNINGMSG_CONSTQUALIFIERDISCARDED )
  592                     end if
  593                 end if
  594 
  595             end if
  596 
  597         end if
  598     
  599 
  600     end if
  601 
  602     if( env.clopt.backend = FB_BACKEND_GAS ) then
  603         if( doconv ) then
  604             '' converting DOUBLE to SINGLE?
  605             if( typeGet( ldtype ) = FB_DATATYPE_DOUBLE ) then
  606                 n->cast.do_convfd2fs = (typeGet( to_dtype ) = FB_DATATYPE_SINGLE)
  607             end if
  608         end if
  609     end if
  610 
  611     function = n
  612 
  613 end function
  614 
  615 '':::::
  616 function astNewOvlCONV _
  617     ( _
  618         byval to_dtype as integer, _
  619         byval to_subtype as FBSYMBOL ptr, _
  620         byval l as ASTNODE ptr _
  621     ) as ASTNODE ptr
  622 
  623     '' try casting op overloading only
  624     hDoGlobOpOverload( to_dtype, to_subtype, l )
  625 
  626     '' nothing to do
  627     function = l
  628 
  629 end function
  630 
  631 sub astUpdateCONVFD2FS _
  632     ( _
  633         byval n as ASTNODE ptr, _
  634         byval to_dtype as integer, _
  635         byval is_expr as integer _
  636     )
  637 
  638     assert( n->class = AST_NODECLASS_CONV )
  639 
  640     '' only when converting DOUBLE to SINGLE
  641     if( n->cast.do_convfd2fs = FALSE ) then
  642         exit sub
  643     end if
  644 
  645     assert( env.clopt.backend = FB_BACKEND_GAS )
  646 
  647     ''
  648     '' x86 assumptions
  649     ''
  650     '' Don't do the DOUBLE to SINGLE truncation unless needed.
  651     ''
  652     '' If the target dtype cannot hold bigger values than SINGLE
  653     '' anyways, then we don't need to do the additional truncation,
  654     '' that will happen automatically when storing into the target.
  655     ''
  656     '' This applies to stores (ASSIGN, ARG), and to expressions
  657     '' that do not use the FPU stack (ST(N) registers).
  658     ''
  659 
  660     '' everything >= 4 bytes, assuming that 4 byte integers can hold values
  661     '' that still are too big for SINGLE
  662     n->cast.do_convfd2fs = (typeGetSize( to_dtype ) >= 4)
  663 
  664     '' to SINGLE itself? no need to do anything then, except if it's on
  665     '' the FPU stack, and won't be automatically truncated because of that.
  666     if( typeGet( to_dtype ) = FB_DATATYPE_SINGLE ) then
  667         n->cast.do_convfd2fs = is_expr
  668     end if
  669 
  670 end sub
  671 
  672 '':::::
  673 function astLoadCONV _
  674     ( _
  675         byval n as ASTNODE ptr _
  676     ) as IRVREG ptr
  677 
  678     dim as ASTNODE ptr l = any
  679     dim as IRVREG ptr vs = any, vr = any
  680 
  681     l = n->l
  682 
  683     if( l = NULL ) then
  684         return NULL
  685     end if
  686 
  687     vs = astLoad( l )
  688 
  689     '' n->cast
  690     '' doconv convconst    do_convfd2fs
  691     '' false  false        n/a           same size
  692     '' false  true         n/a           same size - different const qualifiers, doesn't matter now
  693     '' true   false        false         different sizes
  694     '' true   false        true          convert floating point double to single
  695     '' true   true         n/a           different sizes  - different const qualifiers, doesn't matter now
  696 
  697     if( ast.doemit ) then
  698         vs->vector = n->vector
  699         if( n->cast.doconv ) then
  700             vr = irAllocVreg( astGetFullType( n ), n->subtype )
  701             vr->vector = n->vector
  702             irEmitConvert( vr, vs )
  703 
  704             if( n->cast.do_convfd2fs ) then
  705                 '' converting DOUBLE to SINGLE?
  706                 if( vs->dtype = FB_DATATYPE_DOUBLE ) then
  707                     if( vr->dtype = FB_DATATYPE_SINGLE ) then
  708                         if( vr->regFamily = IR_REG_FPU_STACK ) then
  709                             '' Do additional conversion to truncate to SINGLE
  710                             irEmitUOP( AST_OP_CONVFD2FS, vr, NULL )
  711                         end if
  712                     end if
  713                 end if
  714             end if
  715         else
  716             vr = vs
  717             irSetVregDataType( vr, astGetFullType( n ), n->subtype )
  718         end if
  719     end if
  720 
  721     astDelNode( l )
  722 
  723     function = vr
  724 
  725 end function
  726 
  727 function astSkipConstCASTs( byval n as ASTNODE ptr ) as ASTNODE ptr
  728     function = n
  729     if( n->class = AST_NODECLASS_CONV ) then
  730         if( n->cast.doconv = FALSE ) then
  731             function = n->l
  732         end if
  733     end if
  734 end function
  735 
  736 function astSkipNoConvCAST( byval n as ASTNODE ptr ) as ASTNODE ptr
  737     function = n
  738     if( n->class = AST_NODECLASS_CONV ) then
  739         if( n->cast.doconv = FALSE and n->cast.convconst = FALSE ) then
  740             function = n->l
  741         end if
  742     end if
  743 end function
  744 
  745 function astRemoveNoConvCAST( byval n as ASTNODE ptr ) as ASTNODE ptr
  746     function = n
  747     if( n->class = AST_NODECLASS_CONV ) then
  748         if( n->cast.doconv = FALSE and n->cast.convconst = FALSE ) then
  749             function = n->l
  750             n->l = NULL
  751             astDelTree( n )
  752         end if
  753     end if
  754 end function
  755 
  756 function astSkipCASTs( byval n as ASTNODE ptr ) as ASTNODE ptr
  757     while( n->class = AST_NODECLASS_CONV )
  758         n = n->l
  759     wend
  760     function = n
  761 end function
  762 
  763 function astRemoveCASTs( byval n as ASTNODE ptr ) as ASTNODE ptr
  764     while( n->class = AST_NODECLASS_CONV )
  765         var l = n->l
  766         astDelNode( n )
  767         n = l
  768     wend
  769     function = n
  770 end function