@@ -11,6 +11,8 @@ import Util.System
1111import Control.Applicative
1212import Control.Arrow
1313import Control.Monad
14+import qualified Control.Monad.Trans as T
15+import Control.Monad.Trans.State
1416import Data.Char
1517import Data.Maybe (fromJust)
1618import Language.Java.Parser
@@ -23,19 +25,26 @@ import System.FilePath
2325import System.IO
2426import System.Process
2527
26−codegenJava :: [(Name, SDecl)] ->
28+data CodeGenerationEnv = CodeGenerationEnv { globalVariablePositions :: [(Name, Integer)] }
29+
30+type CodeGeneration = StateT (CodeGenerationEnv) (Either String)
31+
32+codegenJava :: [(Name, SExp)] -> -- initialization of globals
33+ [(Name, SDecl)] ->
2734 FilePath -> -- output file name
2835 OutputType ->
2936 IO ()
30−codegenJava defs out exec =
37+codegenJava globalInit defs out exec =
3138 either (error)
3239 (writeFile out . flatIndent . prettyPrint)
33− (mkCompilationUnit defs out)
40+ ( evalStateT (mkCompilationUnit globalInit defs out) (mkCodeGenEnv globalInit) )
3441
35−mkCompilationUnit :: [(Name, SDecl)] ->
36− FilePath ->
37− Either String CompilationUnit
38−mkCompilationUnit defs out =
42+mkCodeGenEnv :: [(Name, SExp)] -> CodeGenerationEnv
43+mkCodeGenEnv globalInit =
44+ CodeGenerationEnv $ zipWith (\ (name, _) pos -> (name, pos)) globalInit [0..]
45+
46+mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> FilePath -> CodeGeneration CompilationUnit
47+mkCompilationUnit globalInit defs out =
3948 CompilationUnit Nothing [ ImportDecl False idrisRts True
4049 , ImportDecl True idrisForeign True
4150 , ImportDecl False bigInteger False
@@ -44,7 +53,7 @@ mkCompilationUnit defs out =
4453 , ImportDecl False scanner False
4554 , ImportDecl False arrays False
4655 ] <$>
47− mkTypeDecl defs out
56+ mkTypeDecl globalInit defs out
4857 where
4958 idrisRts = J.Name $ map Ident ["org", "idris", "rts"]
5059 idrisForeign = J.Name $ map Ident ["org", "idris", "rts", "ForeignPrimitives"]
@@ -75,10 +84,8 @@ prefixCallNamespacesCase name (SDefaultCase e) = SDefaultCase (prefixCallNamespa
7584prefixCallNamespacesDecl :: Ident -> SDecl -> SDecl
7685prefixCallNamespacesDecl name (SFun fname args i e) = SFun fname args i (prefixCallNamespaces name e)
7786
78−mkTypeDecl :: [(Name, SDecl)] ->
79− FilePath ->
80− Either String [TypeDecl]
81−mkTypeDecl defs out =
87+mkTypeDecl :: [(Name, SExp)] -> [(Name, SDecl)] -> FilePath -> CodeGeneration [TypeDecl]
88+mkTypeDecl globalInit defs out =
8289 (\ name body -> [ClassTypeDecl $ ClassDecl [ Public
8390 , Annotation $ SingleElementAnnotation
8491 (J.Name [Ident "SuppressWarnings"])
@@ -91,18 +98,33 @@ mkTypeDecl defs out =
9198 body])
9299 <$> mkClassName out
93100 <*> ( mkClassName out
94− >>= (\ ident -> mkClassBody (map (second (prefixCallNamespacesDecl ident)) defs))
101+ >>= (\ ident -> mkClassBody globalInit (map (second (prefixCallNamespacesDecl ident)) defs))
95102 )
96103
97−mkClassName :: FilePath -> Either String Ident
104+mkClassName :: FilePath -> CodeGeneration Ident
98105mkClassName path =
99− left (\ err -> "Parser error in \"" ++ path ++ "\": " ++ (show err))
100− (parser ident . takeBaseName $ takeFileName path)
106+ T.lift $ left (\ err -> "Parser error in \"" ++ path ++ "\": " ++ (show err))
107+ (parser ident . takeBaseName $ takeFileName path)
108+
109+mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody
110+mkClassBody globalInit defs =
111+ (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs)
112+ <$> mkGlobalContext globalInit
113+ <*> mapM mkDecl defs
114+
115+mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]
116+mkGlobalContext [] = return []
117+mkGlobalContext initExps =
118+ (\ exps -> [ MemberDecl $ FieldDecl [Private, Static, Final]
119+ objectArrayType
120+ [VarDecl (VarId $ Ident "globalContext")
121+ (Just . InitArray $ ArrayInit exps)
122+ ]
123+ ]
124+ )
125+ <$> mapM (\ (_, exp) -> InitExp <$> mkExp exp) initExps
101126
102−mkClassBody :: [(Name, SDecl)] ->
103− Either String ClassBody
104−mkClassBody defs = (ClassBody . addMainMethod . mergeInnerClasses)
105− <$> mapM mkDecl defs
127+
106128
107129addMainMethod :: [Decl] -> [Decl]
108130addMainMethod decls
@@ -160,17 +182,17 @@ mergeInnerClasses = foldl mergeInner []
160182 mergeInner [] decl' = [decl']
161183
162184
163−mkIdentifier :: Name -> Either String Ident
185+mkIdentifier :: Name -> CodeGeneration Ident
164186mkIdentifier (NS name _) = mkIdentifier name
165187mkIdentifier (MN i name) = (\ (Ident x) -> Ident $ x ++ ('_' : show i))
166188 <$> mkIdentifier (UN name)
167189mkIdentifier (UN name) =
168− left (\ err -> "Parser error in \"" ++ name ++ "\": " ++ (show err))
169− ( parser ident
170− . cleanReserved
171− . cleanNonLetter
172− . cleanStart
173− $ cleanWs False name)
190+ T.lift $ left (\ err -> "Parser error in \"" ++ name ++ "\": " ++ (show err))
191+ ( parser ident
192+ . cleanReserved
193+ . cleanNonLetter
194+ . cleanStart
195+ $ cleanWs False name)
174196 where
175197 cleanStart (x:xs)
176198 | isNumber x = '_' : (x:xs)
@@ -207,6 +229,7 @@ mkIdentifier (UN name) =
207229
208230
209231 cleanReserved "param" = "_param"
232+ cleanReserved "globalContext" = "_globalContext"
210233 cleanReserved "context" = "_context"
211234 cleanReserved "newcontext" = "_newcontext"
212235
@@ -306,7 +329,7 @@ mkIdentifier (UN name) =
306329
307330 cleanReserved x = x
308331
309−mkName :: Name -> Either String J.Name
332+mkName :: Name -> CodeGeneration J.Name
310333mkName (NS name nss) = (\ n ns -> J.Name (n:ns))
311334 <$> mkIdentifier name
312335 <*> mapM (mkIdentifier . UN) nss
@@ -333,8 +356,9 @@ idrisTailCallClosureType = ClassType [(Ident "TailCallClosure", [])]
333356idrisObjectType :: ClassType
334357idrisObjectType = ClassType [(Ident "IdrisObject", [])]
335358
336−contextArray :: Exp
337−contextArray = ExpName $ J.Name [Ident "context"]
359+contextArray :: LVar -> Exp
360+contextArray (Loc _) = ExpName $ J.Name [Ident "context"]
361+contextArray (Glob _) = ExpName $ J.Name [Ident "globalContext"]
338362
339363charType :: ClassType
340364charType = ClassType [(Ident "Character", [])]
@@ -372,12 +396,11 @@ runtimeExceptionType = ClassType [(Ident "RuntimeException", [])]
372396comparableType :: ClassType
373397comparableType = ClassType [(Ident "Comparable", [])]
374398
375−mkDecl :: (Name, SDecl) ->
376− Either String Decl
399+mkDecl :: (Name, SDecl) -> CodeGeneration Decl
377400mkDecl ((NS n (ns:nss)), decl) =
378401 (\ name body -> MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
379402 <$> mkIdentifier (UN ns)
380− <*> mkClassBody [(NS n nss, decl)]
403+ <*> mkClassBody [] [(NS n nss, decl)]
381404mkDecl (_, SFun name params stackSize body) =
382405 (\ name params paramNames methodBody ->
383406 MemberDecl $ MethodDecl [Public, Static]
@@ -404,7 +427,7 @@ mkDecl (_, SFun name params stackSize body) =
404427 <*> mkExp body
405428
406429
407−mkClosure :: [Name] -> Int -> SExp -> Either String Exp
430+mkClosure :: [Name] -> Int -> SExp -> CodeGeneration Exp
408431mkClosure params stackSize body =
409432 (\ paramArray body ->
410433 InstanceCreation []
@@ -415,22 +438,22 @@ mkClosure params stackSize body =
415438 <$> mkStackInit params stackSize
416439 <*> mkClosureCall body
417440
418−mkFormalParam :: Name -> Either String FormalParam
441+mkFormalParam :: Name -> CodeGeneration FormalParam
419442mkFormalParam name =
420443 (\ name -> FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId name))
421444 <$> mkIdentifier name
422445
423−mkClosureCall :: SExp -> Either String Decl
446+mkClosureCall :: SExp -> CodeGeneration Decl
424447mkClosureCall body =
425448 (\ body -> MemberDecl $ MethodDecl [Public] [] (Just . RefType $ ClassRefType objectType) (Ident "call") [] [] body)
426449 <$> mkMethodBody body
427450
428−mkMethodBody :: SExp -> Either String MethodBody
451+mkMethodBody :: SExp -> CodeGeneration MethodBody
429452mkMethodBody exp =
430453 (\ exp -> MethodBody . Just . Block $ [BlockStmt . Return . Just $ exp])
431454 <$> mkExp exp
432455
433−mkStackInit :: [Name] -> Int -> Either String Exp
456+mkStackInit :: [Name] -> Int -> CodeGeneration Exp
434457mkStackInit params stackSize =
435458 (\ localVars -> ArrayCreateInit objectArrayType 0 . ArrayInit $
436459 (map (InitExp . ExpName) localVars)
@@ -445,7 +468,7 @@ mkFlipK :: Exp -> Exp -> Exp
445468mkFlipK drop result =
446469 MethodInv $ MethodCall (J.Name [Ident "idris_flipK"]) [ drop, result ]
447470
448−mkLet :: LVar -> SExp -> SExp -> Either String Exp
471+mkLet :: LVar -> SExp -> SExp -> CodeGeneration Exp
449472mkLet (Loc pos) oldExp newExp =
450473 (\ oldExp newExp ->
451474 mkFlipK ( Assign ( ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "context"])
@@ -457,13 +480,13 @@ mkLet (Loc pos) oldExp newExp =
457480 )
458481 <$> mkExp oldExp
459482 <*> mkExp newExp
460−
483+mkLet (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"
461484
462485reverseNameSpace :: J.Name -> J.Name
463486reverseNameSpace (J.Name ids) =
464487 J.Name ((tail ids) ++ [head ids])
465488
466−mkCase :: Bool -> LVar -> [SAlt] -> Either String Exp
489+mkCase :: Bool -> LVar -> [SAlt] -> CodeGeneration Exp
467490mkCase checked var ((SConCase parentStackPos consIndex _ params branchExpression):cases) =
468491 mkConsCase checked
469492 var
@@ -473,11 +496,11 @@ mkCase checked var ((SConCase parentStackPos consIndex _ params branchExpression
473496 branchExpression
474497 (SCase var cases)
475498mkCase checked var (c@(SConstCase constant branchExpression):cases) =
476− (\ constant branchExpression alternative ->
499+ (\ constant branchExpression alternative var->
477500 Cond ( MethodInv $ PrimaryMethodCall (constant)
478501 []
479502 (Ident "equals")
480− [mkVarAccess Nothing var]
503+ [var]
481504 )
482505 branchExpression
483506 alternative
@@ -485,10 +508,11 @@ mkCase checked var (c@(SConstCase constant branchExpression):cases) =
485508 <$> mkExp (SConst constant)
486509 <*> mkExp branchExpression
487510 <*> mkCase checked var cases
511+ <*> mkVarAccess Nothing var
488512mkCase checked var (SDefaultCase exp:cases) = mkExp exp
489513mkCase checked _ [] = mkExp (SError "Non-exhaustive pattern")
490514
491−mkConsCase :: Bool -> LVar -> Int -> Int -> [Name] -> SExp -> SExp -> Either String Exp
515+mkConsCase :: Bool -> LVar -> Int -> Int -> [Name] -> SExp -> SExp -> CodeGeneration Exp
492516mkConsCase checked
493517 toDeconstruct
494518 parentStackStart
@@ -496,13 +520,13 @@ mkConsCase checked
496520 params
497521 branchExpression
498522 alternative =
499− (\ caseBinding alternative->
500− Cond (BinOp (InstanceOf (mkVarAccess Nothing toDeconstruct)
523+ (\ caseBinding alternative var varCasted->
524+ Cond (BinOp (InstanceOf (var)
501525 (ClassRefType idrisObjectType)
502526 )
503527 CAnd
504528 ( BinOp
505− ( MethodInv $ PrimaryMethodCall (mkVarAccess (Just idrisObjectType) toDeconstruct)
529+ ( MethodInv $ PrimaryMethodCall (varCasted)
506530 []
507531 (Ident "getConstructorId")
508532 []
@@ -516,20 +540,24 @@ mkConsCase checked
516540 )
517541 <$> mkCaseBinding checked toDeconstruct parentStackStart params branchExpression
518542 <*> mkExp alternative
543+ <*> mkVarAccess (Nothing) toDeconstruct
544+ <*> mkVarAccess (Just idrisObjectType) toDeconstruct
519545
520546
521−mkCaseBinding :: Bool -> LVar -> Int -> [Name] -> SExp -> Either String Exp
547+mkCaseBinding :: Bool -> LVar -> Int -> [Name] -> SExp -> CodeGeneration Exp
522548mkCaseBinding True var parentStackStart params branchExpression =
523− (\ branchExpression -> mkFlipK (MethodInv $ MethodCall (J.Name [Ident "idris_assignStack"])
524− ( (ExpName $ J.Name [Ident "context"])
525− : (Lit $ Int (toInteger parentStackStart))
526− : (mkCaseBindingDeconstruction var params)
527− ))
528− (branchExpression)
549+ (\ branchExpression deconstruction ->
550+ mkFlipK (MethodInv $ MethodCall (J.Name [Ident "idris_assignStack"])
551+ ( (ExpName $ J.Name [Ident "context"])
552+ : (Lit $ Int (toInteger parentStackStart))
553+ : deconstruction
554+ ))
555+ (branchExpression)
529556 )
530557 <$> mkExp branchExpression
558+ <*> mkCaseBindingDeconstruction var params
531559mkCaseBinding False var parentStackStart params branchExpression =
532− (\ bindingMethod ->
560+ (\ bindingMethod deconstruction ->
533561 MethodInv $ PrimaryMethodCall
534562 ( MethodInv $ PrimaryMethodCall (InstanceCreation []
535563 (ClassType [(Ident "Object", [])])
@@ -538,21 +566,20 @@ mkCaseBinding False var parentStackStart params branchExpression =
538566 )
539567 []
540568 (Ident "apply")
541− ( contextArray
542− : (mkCaseBindingDeconstruction var params)
543− )
569+ ( contextArray (Loc undefined) : deconstruction )
544570 )
545571 []
546572 (Ident "call")
547573 []
548574 )
549575 <$> mkCaseBindingMethod parentStackStart params branchExpression
576+ <*> mkCaseBindingDeconstruction var params
550577
551−mkCaseBindingDeconstruction :: LVar -> [Name] -> [Exp]
578+mkCaseBindingDeconstruction :: LVar -> [Name] -> CodeGeneration [Exp]
552579mkCaseBindingDeconstruction var members =
553− map (mkProjection var) ([0..(length members - 1)])
580+ mapM (mkProjection var) ([0..(length members - 1)])
554581
555−mkCaseBindingMethod :: Int -> [Name] -> SExp -> Either String MemberDecl
582+mkCaseBindingMethod :: Int -> [Name] -> SExp -> CodeGeneration MemberDecl
556583mkCaseBindingMethod parentStackStart params branchExpression =
557584 (\ formalParams caseBindingStack branchExpression ->
558585 MethodDecl [Final, Public]
@@ -572,7 +599,7 @@ mkContextParam :: FormalParam
572599mkContextParam =
573600 FormalParam [Final] (objectArrayType) False (VarId (Ident "context"))
574601
575−mkBindingClosure :: SExp -> Either String Exp
602+mkBindingClosure :: SExp -> CodeGeneration Exp
576603mkBindingClosure oldExp =
577604 (\ oldCall ->
578605 InstanceCreation []
@@ -583,7 +610,7 @@ mkBindingClosure oldExp =
583610 <$> mkClosureCall oldExp
584611
585612
586−mkBindingStack :: Bool -> Int -> [Name] -> Either String [BlockStmt]
613+mkBindingStack :: Bool -> Int -> [Name] -> CodeGeneration [BlockStmt]
587614mkBindingStack checked parentStackStart params =
588615 (\ paramNames ->
589616 ( LocalVars [Final]
@@ -622,15 +649,17 @@ mkContextCopy False parentStackStart params =
622649 ]
623650 ]
624651
625−mkProjection :: LVar -> Int -> Exp
652+mkProjection :: LVar -> Int -> CodeGeneration Exp
626653mkProjection var memberNr =
627− ArrayAccess $ ArrayIndex ( MethodInv $ PrimaryMethodCall
628− (mkVarAccess (Just idrisObjectType) var)
629− []
630− (Ident "getData")
631− []
632− )
633− (Lit $ Int (toInteger memberNr))
654+ (\ var -> ArrayAccess $ ArrayIndex ( MethodInv $ PrimaryMethodCall
655+ (var)
656+ []
657+ (Ident "getData")
658+ []
659+ )
660+ (Lit $ Int (toInteger memberNr))
661+ )
662+ <$> mkVarAccess (Just idrisObjectType) var
634663
635664type ClassName = String
636665
@@ -645,22 +674,22 @@ mkClass :: ClassType -> Exp
645674mkClass classType =
646675 ClassLit . Just . RefType .ClassRefType $ classType
647676
648−mkBinOpExp :: ClassType -> Op -> [LVar] -> Exp
649−mkBinOpExp castTo op (var:vars) =
650− foldl (\ exp -> BinOp exp op . mkVarAccess (Just castTo))
651− (mkVarAccess (Just castTo) var)
677+mkBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp
678+mkBinOpExp castTo op (var:vars) = do
679+ start <- mkVarAccess (Just castTo) var
680+ foldM (\ exp var -> BinOp exp op <$> mkVarAccess (Just castTo) var) start vars
681+
682+mkBinOpExpTrans :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> Op -> [LVar] -> CodeGeneration Exp
683+mkBinOpExpTrans opTransformation resultTransformation castTo op (var:vars) = do
684+ start <- (mkVarAccess (Just castTo) var)
685+ foldM (\ exp var -> resultTransformation
686+ . BinOp (opTransformation exp) op
687+ . opTransformation
688+ <$> mkVarAccess (Just castTo) var)
689+ start
652690 vars
653691
654−mkBinOpExpTrans :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> Op -> [LVar] -> Exp
655−mkBinOpExpTrans opTransformation resultTransformation castTo op (var:vars) =
656− foldl (\ exp -> resultTransformation
657− . BinOp (opTransformation exp) op
658− . opTransformation
659− . mkVarAccess (Just castTo))
660− (mkVarAccess (Just castTo) var)
661− vars
662−
663−mkBinOpExpConv :: String -> PrimType -> ClassType -> Op -> [LVar] -> Exp
692+mkBinOpExpConv :: String -> PrimType -> ClassType -> Op -> [LVar] -> CodeGeneration Exp
664693mkBinOpExpConv fromMethodName toType fromType@(ClassType [(cls@(Ident _), [])]) op args =
665694 mkBinOpExpTrans (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
666695 []
@@ -676,59 +705,70 @@ mkBinOpExpConv fromMethodName toType fromType@(ClassType [(cls@(Ident _), [])])
676705 op
677706 args
678707
679−mkLogicalBinOpExp :: ClassType -> Op -> [LVar] -> Exp
680−mkLogicalBinOpExp castTo op (var:vars) =
681− foldl (\ exp -> mkBoolToNumber castTo . BinOp exp op . mkVarAccess (Just castTo))
682− (mkVarAccess (Just castTo) var)
708+mkLogicalBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp
709+mkLogicalBinOpExp castTo op (var:vars) = do
710+ start <- mkVarAccess (Just castTo) var
711+ foldM (\ exp var -> mkBoolToNumber castTo . BinOp exp op <$> mkVarAccess (Just castTo) var)
712+ start
683713 vars
684714
685−mkMethodOpChain1 :: (Exp -> Exp) -> ClassType -> String -> [LVar] -> Exp
715+mkMethodOpChain1 :: (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp
686716mkMethodOpChain1 = mkMethodOpChain id
687717
688−mkMethodOpChain :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> String -> [LVar] -> Exp
689−mkMethodOpChain initialTransformation resultTransformation castTo method (arg:args) =
690− foldl (\ exp arg' ->
691− resultTransformation . MethodInv $ PrimaryMethodCall exp
692− []
693− (Ident method)
694− [mkVarAccess (Just $ castTo) arg']
718+mkMethodOpChain :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp
719+mkMethodOpChain initialTransformation resultTransformation castTo method (arg:args) = do
720+ start <- initialTransformation <$> mkVarAccess (Just $ castTo) arg
721+ foldM (\ exp arg' ->
722+ resultTransformation
723+ . MethodInv
724+ . PrimaryMethodCall exp [] (Ident method)
725+ . (:[])
726+ <$> mkVarAccess (Just $ castTo) arg'
695727 )
696− (initialTransformation (mkVarAccess (Just $ castTo) arg))
728+ start
697729 args
698730
699731mkBoolToNumber :: ClassType -> Exp -> Exp
700732mkBoolToNumber (ClassType [(Ident name, [])]) boolExp =
701733 Cond boolExp (mkPrimitive name (Int 1)) (mkPrimitive name (Int 0))
702734
703−mkZeroExt :: String -> Int -> ClassType -> ClassType -> LVar -> Exp
704−mkZeroExt toMethod bits fromType toType@(ClassType [(toTypeName, [])]) var =
705− MethodInv $ TypeMethodCall (J.Name [toTypeName])
706− []
707− (Ident "valueOf")
708− [ Cond ( BinOp (mkVarAccess (Just $ fromType) var)
709− LThan
710− (Lit $ Int 0)
711− )
712− ( BinOp (Lit $ Int (2^bits))
713− Add
714− (mkSignedExt' toMethod fromType var)
715− )
716− (mkSignedExt' toMethod fromType var)
717− ]
735+mkZeroExt :: String -> Int -> ClassType -> ClassType -> LVar -> CodeGeneration Exp
736+mkZeroExt toMethod bits fromType toType@(ClassType [(toTypeName, [])]) var = do
737+ (\ var sext ->
738+ MethodInv $ TypeMethodCall (J.Name [toTypeName])
739+ []
740+ (Ident "valueOf")
741+ [ Cond ( BinOp (var)
742+ LThan
743+ (Lit $ Int 0)
744+ )
745+ ( BinOp (Lit $ Int (2^bits))
746+ Add
747+ (sext)
748+ )
749+ sext
750+ ]
751+ )
752+ <$> mkVarAccess (Just $ fromType) var
753+ <*> mkSignedExt' toMethod fromType var
718754
719−mkSignedExt :: String -> ClassType -> ClassType -> LVar -> Exp
755+mkSignedExt :: String -> ClassType -> ClassType -> LVar -> CodeGeneration Exp
720756mkSignedExt toMethod fromType (ClassType [(toTypeName, [])]) var =
721− MethodInv $ TypeMethodCall (J.Name [toTypeName])
722− []
723− (Ident "valueOf")
724− [ mkSignedExt' toMethod fromType var ]
757+ (\ sext -> MethodInv $ TypeMethodCall (J.Name [toTypeName])
758+ []
759+ (Ident "valueOf")
760+ [ sext ]
761+ )
762+ <$> mkSignedExt' toMethod fromType var
725763
726−mkSignedExt' :: String -> ClassType -> LVar -> Exp
764+mkSignedExt' :: String -> ClassType -> LVar -> CodeGeneration Exp
727765mkSignedExt' toMethod fromType var =
728− MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ fromType) var)
729− []
730− (Ident toMethod)
731− []
766+ (\ var -> MethodInv $ PrimaryMethodCall (var)
767+ []
768+ (Ident toMethod)
769+ []
770+ )
771+ <$> mkVarAccess (Just $ fromType) var
732772
733773data SPartialOrder
734774 = SLt
@@ -750,26 +790,39 @@ mkPartialOrder SGe x =
750790 (BinOp (Lit $ Int 0) Equal x)
751791mkPartialOrder SGt x = (BinOp (Lit $ Int 1) Equal x)
752792
753−mkVarAccess :: Maybe ClassType -> LVar -> Exp
754−mkVarAccess Nothing (Loc i) =
755− ArrayAccess $ ArrayIndex contextArray (Lit $ Int (toInteger i))
793+varPos :: LVar -> CodeGeneration Integer
794+varPos (Loc i) = return (toInteger i)
795+varPos (Glob name) = do
796+ positions <- globalVariablePositions <$> get
797+ case lookup name positions of
798+ (Just pos) -> return pos
799+ Nothing -> T.lift . Left $ "Invalid global variable id: " ++ show name
800+
801+mkVarAccess :: Maybe ClassType -> LVar -> CodeGeneration Exp
802+mkVarAccess Nothing var =
803+ (\ pos -> ArrayAccess $ ArrayIndex (contextArray var) (Lit $ Int pos))
804+ <$> varPos var
756805mkVarAccess (Just castTo) var =
757− Cast (RefType . ClassRefType $ castTo) (mkVarAccess Nothing var)
806+ Cast (RefType . ClassRefType $ castTo) <$> (mkVarAccess Nothing var)
758807
759−mkPrimitiveCast :: ClassType -> ClassType -> LVar -> Exp
808+mkPrimitiveCast :: ClassType -> ClassType -> LVar -> CodeGeneration Exp
760809mkPrimitiveCast fromType (ClassType [(toType, [])]) var =
761− MethodInv $ TypeMethodCall (J.Name [toType])
762− []
763− (Ident "valueOf")
764− [mkVarAccess (Just fromType) var]
765−
766−mkToString :: ClassType -> LVar -> Exp
767−mkToString castTo var =
768− MethodInv $ PrimaryMethodCall (mkVarAccess (Just castTo) var)
769− []
770− (Ident "toString")
810+ (\ var ->
811+ MethodInv $ TypeMethodCall (J.Name [toType])
771812 []
813+ (Ident "valueOf")
814+ [var]
815+ )
816+ <$> mkVarAccess (Just fromType) var
772817
818+mkToString :: ClassType -> LVar -> CodeGeneration Exp
819+mkToString castTo var =
820+ (\ var -> MethodInv $ PrimaryMethodCall (var)
821+ []
822+ (Ident "toString")
823+ []
824+ )
825+ <$> mkVarAccess (Just castTo) var
773826data Std = In | Out | Err
774827
775828instance Show Std where
@@ -787,49 +840,57 @@ mkSystemOutPrint value =
787840 (Ident "print")
788841 [value]
789842
790−mkMathFun :: String -> LVar -> Exp
843+mkMathFun :: String -> LVar -> CodeGeneration Exp
791844mkMathFun funName var =
792− MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
793− []
794− (Ident "valueOf")
795− [ MethodInv $ TypeMethodCall (J.Name [Ident "Math"])
796− []
797− (Ident funName)
798− [mkVarAccess (Just doubleType) var]
799− ]
845+ (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
846+ []
847+ (Ident "valueOf")
848+ [ MethodInv $ TypeMethodCall (J.Name [Ident "Math"])
849+ []
850+ (Ident funName)
851+ [var]
852+ ]
853+ )
854+ <$> mkVarAccess (Just doubleType) var
800855
801−mkStringAtIndex :: LVar -> Exp -> Exp
856+mkStringAtIndex :: LVar -> Exp -> CodeGeneration Exp
802857mkStringAtIndex var indexExp =
803− MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])
804− []
805− (Ident "valueOf")
806− [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just stringType) var)
807− []
808− (Ident "charAt")
809− [indexExp]
810− ]
858+ (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])
859+ []
860+ (Ident "valueOf")
861+ [ MethodInv $ PrimaryMethodCall (var)
862+ []
863+ (Ident "charAt")
864+ [indexExp]
865+ ]
866+ )
867+ <$> mkVarAccess (Just stringType) var
811868
812869mkForeignType :: FType -> Maybe ClassType
813−mkForeignType FInt = return $ integerType
814−mkForeignType FChar = return $ integerType
815−mkForeignType FString = return $ stringType
816−mkForeignType FPtr = return $ objectType
817−mkForeignType FDouble = return $ doubleType
818−mkForeignType FAny = return $ objectType
870+mkForeignType FInt = return integerType
871+mkForeignType FChar = return integerType
872+mkForeignType FString = return stringType
873+mkForeignType FPtr = return objectType
874+mkForeignType FDouble = return doubleType
875+mkForeignType FAny = return objectType
819876mkForeignType FUnit = Nothing
820877
821−mkForeignVarAccess :: FType -> LVar -> Exp
878+mkForeignVarAccess :: FType -> LVar -> CodeGeneration Exp
822879mkForeignVarAccess FInt var =
823− MethodInv $ PrimaryMethodCall (mkVarAccess (Just integerType) var)
824− []
825− (Ident "intValue")
826− []
827−mkForeignVarAccess FChar var = Cast (PrimType CharT) (mkForeignVarAccess FInt var)
880+ (\ var -> MethodInv $ PrimaryMethodCall (var)
881+ []
882+ (Ident "intValue")
883+ []
884+ )
885+ <$> mkVarAccess (Just integerType) var
886+mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess FInt var
828887mkForeignVarAccess FDouble var =
829− MethodInv $ PrimaryMethodCall (mkVarAccess (Just doubleType) var)
830− []
831− (Ident "doubleValue")
832− []
888+ (\ var -> MethodInv $ PrimaryMethodCall (var)
889+ []
890+ (Ident "doubleValue")
891+ []
892+ )
893+ <$> mkVarAccess (Just doubleType) var
833894mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var
834895
835896mkFromForeignType :: FType -> Exp -> Exp
@@ -846,7 +907,7 @@ mkFromForeignType FDouble from =
846907 [from]
847908mkFromForeignType _ from = from
848909
849−mkForeignInvoke :: FType -> String -> [(FType, LVar)] -> Either String Exp
910+mkForeignInvoke :: FType -> String -> [(FType, LVar)] -> CodeGeneration Exp
850911mkForeignInvoke fType method args =
851912 (\ foreignInvokeMeth ->
852913 MethodInv $ PrimaryMethodCall (InstanceCreation []
@@ -861,7 +922,7 @@ mkForeignInvoke fType method args =
861922 <$> mkForeignInvokeMethod fType method args
862923
863924
864−mkForeignInvokeMethod :: FType -> String -> [(FType, LVar)] -> Either String MemberDecl
925+mkForeignInvokeMethod :: FType -> String -> [(FType, LVar)] -> CodeGeneration MemberDecl
865926mkForeignInvokeMethod fType method args =
866927 (\ tryBlock ->
867928 MethodDecl [Public, Final]
@@ -870,111 +931,124 @@ mkForeignInvokeMethod fType method args =
870931 (Ident "foreignInvoke")
871932 []
872933 []
873− (MethodBody . Just $ Block [ BlockStmt $
874− Try tryBlock
875− [ Catch (FormalParam []
876− (RefType $ ClassRefType exceptionType)
877− False
878− (VarId $ Ident "ex")
879− )
880− (Block [ BlockStmt . Throw $
881− InstanceCreation []
882− runtimeExceptionType
883− [ExpName $ J.Name [Ident "ex"]]
884− Nothing
885− ]
886− )
887− ]
888− Nothing
889− ]
934+ (MethodBody . Just $ Block
935+ [ BlockStmt
936+ $ Try tryBlock
937+ [ Catch (FormalParam []
938+ (RefType $ ClassRefType exceptionType)
939+ False
940+ (VarId $ Ident "ex")
941+ )
942+ (Block [ BlockStmt
943+ . Throw
944+ $ InstanceCreation []
945+ runtimeExceptionType
946+ [ExpName $ J.Name [Ident "ex"]]
947+ Nothing
948+ ]
949+ )
950+ ]
951+ Nothing
952+ ]
890953 )
891− )
954+ )
892955 <$> mkForeignInvokeTryBlock fType method args
893956
894957
895−mkForeignInvokeTryBlock :: FType -> String -> [(FType, LVar)] -> Either String Block
958+mkForeignInvokeTryBlock :: FType -> String -> [(FType, LVar)] -> CodeGeneration Block
896959mkForeignInvokeTryBlock FUnit method args =
897− (\ method -> Block [ BlockStmt . ExpStmt . MethodInv $
898− MethodCall method
899− (map (uncurry mkForeignVarAccess) args)
900− , BlockStmt $ Return (Just $ Lit Null)
901− ]
960+ (\ method args -> Block [ BlockStmt . ExpStmt . MethodInv $ MethodCall method args
961+ , BlockStmt $ Return (Just $ Lit Null)
962+ ]
902963 )
903− <$> ( left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
904− (parser name method)
964+ <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
965+ (parser name method)
905966 )
967+ <*> mapM (uncurry mkForeignVarAccess) args
906968mkForeignInvokeTryBlock fType method args =
907− (\ method -> Block [ BlockStmt . Return
969+ (\ method args -> Block [ BlockStmt . Return
908970 . Just
909971 . mkFromForeignType fType
910− . MethodInv $
911− MethodCall method
912− (map (uncurry mkForeignVarAccess) args)
913− ]
972+ . MethodInv
973+ $ MethodCall method args
974+ ]
914975 )
915− <$> ( left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
916− (parser name method)
976+ <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
977+ (parser name method)
917978 )
979+ <*> mapM (uncurry mkForeignVarAccess) args
918980
919−mkMethodClosure :: Name -> [LVar] -> Either String Exp
981+mkMethodClosure :: Name -> [LVar] -> CodeGeneration Exp
920982mkMethodClosure name args =
921983 (\ name args ->
922984 InstanceCreation []
923985 idrisClosureType
924986 [ (ExpName $ J.Name [Ident "context"]) ]
925− ( Just $ ClassBody
926− [ MemberDecl $
927− MethodDecl [Public, Final]
928− []
929− (Just . RefType $ ClassRefType objectType)
930− (Ident "call")
931− []
932− []
933− ( MethodBody . Just $
934− Block [ BlockStmt . Return . Just . MethodInv $
935− MethodCall (reverseNameSpace name)
936− args
937− ]
938− )
939− ]
940− )
987+ ( Just
988+ $ ClassBody
989+ [ MemberDecl
990+ $ MethodDecl [Public, Final]
991+ []
992+ (Just . RefType $ ClassRefType objectType)
993+ (Ident "call")
994+ []
995+ []
996+ ( MethodBody
997+ . Just
998+ $ Block [ BlockStmt
999+ . Return
1000+ . Just
1001+ . MethodInv
1002+ $ MethodCall (reverseNameSpace name)
1003+ args
1004+ ]
1005+ )
1006+ ]
1007+ )
9411008 )
9421009 <$> mkName name
9431010 <*> mapM (mkExp . SV) args
9441011
945−mkThread :: LVar -> Either String Exp
1012+mkThread :: LVar -> CodeGeneration Exp
9461013mkThread arg =
947− (\ eval -> MethodInv $
948− PrimaryMethodCall (InstanceCreation []
949− (ClassType [(Ident "Thread", [])])
950− [ eval ]
951− ( Just $ ClassBody
952− [ MemberDecl $ MethodDecl
953− [Public, Final]
954− []
955− (Just . RefType $ ClassRefType objectType)
956− (Ident "_start")
957− []
958− []
959− ( MethodBody . Just $ Block
960− [ BlockStmt . ExpStmt . MethodInv $ MethodCall
961− (J.Name [Ident "start"])
962− []
963− , BlockStmt . Return . Just $ This
1014+ (\ eval ->
1015+ MethodInv
1016+ $ PrimaryMethodCall (InstanceCreation []
1017+ (ClassType [(Ident "Thread", [])])
1018+ [ eval ]
1019+ ( Just
1020+ $ ClassBody [ MemberDecl
1021+ $ MethodDecl [Public, Final]
1022+ []
1023+ (Just . RefType $ ClassRefType objectType)
1024+ (Ident "_start")
1025+ []
1026+ []
1027+ ( MethodBody
1028+ . Just
1029+ $ Block [ BlockStmt
1030+ . ExpStmt
1031+ . MethodInv
1032+ $ MethodCall (J.Name [Ident "start"])
1033+ []
1034+ , BlockStmt
1035+ . Return
1036+ . Just
1037+ $ This
9641038 ]
965− )
966− ]
967− )
968− )
969− []
970− (Ident "_start")
971− []
1039+ )
1040+ ]
1041+ )
1042+ )
1043+ []
1044+ (Ident "_start")
1045+ []
9721046 )
9731047 <$> mkThreadBinding arg
9741048
975−mkThreadBinding :: LVar -> Either String Exp
1049+mkThreadBinding :: LVar -> CodeGeneration Exp
9761050mkThreadBinding var =
977− (\ bindingMethod ->
1051+ (\ bindingMethod var ->
9781052 MethodInv $ PrimaryMethodCall ( InstanceCreation []
9791053 objectType
9801054 []
@@ -982,12 +1056,13 @@ mkThreadBinding var =
9821056 )
9831057 []
9841058 (Ident "apply")
985− [ mkVarAccess Nothing var ]
986− )
1059+ [ var ]
1060+ )
9871061 <$> mkThreadBindingMethod
1062+ <*> mkVarAccess Nothing var
9881063
9891064
990−mkThreadBindingMethod :: Either String MemberDecl
1065+mkThreadBindingMethod :: CodeGeneration MemberDecl
9911066mkThreadBindingMethod =
9921067 (\ compute ->
9931068 MethodDecl [Final, Public]
@@ -1014,9 +1089,8 @@ mkThreadBindingStack =
10141089 ]
10151090
10161091
1017−mkExp :: SExp -> Either String Exp
1018−mkExp (SV var) =
1019− return $ mkVarAccess Nothing var
1092+mkExp :: SExp -> CodeGeneration Exp
1093+mkExp (SV var) = mkVarAccess Nothing var
10201094mkExp (SApp False name args) =
10211095 (\ methClosure ->
10221096 MethodInv $ PrimaryMethodCall ( InstanceCreation []
@@ -1040,11 +1114,13 @@ mkExp (SApp True name args) =
10401114 <$> mkMethodClosure name args
10411115mkExp (SLet var new old) =
10421116 mkLet var old new
1043−mkExp (SUpdate (Loc i) exp) =
1044− (\ rhs -> Assign (ArrayLhs $ ArrayIndex (contextArray) (Lit $ Int (toInteger i)))
1045− EqualA
1046− rhs)
1117+mkExp (SUpdate var exp) =
1118+ (\ rhs varPos -> Assign (ArrayLhs $ ArrayIndex (contextArray var) (Lit $ Int varPos))
1119+ EqualA
1120+ rhs
1121+ )
10471122 <$> mkExp exp
1123+ <*> varPos var
10481124mkExp (SCon conId name args) =
10491125 (\ args -> InstanceCreation []
10501126 idrisObjectType
@@ -1053,7 +1129,7 @@ mkExp (SCon conId name args) =
10531129 <$> mapM (mkExp .SV) args
10541130mkExp (SCase var alts) = mkCase False var alts
10551131mkExp (SChkCase var alts) = mkCase True var alts
1056−mkExp (SProj var i) = return $ mkProjection var i
1132+mkExp (SProj var i) = mkProjection var i
10571133mkExp (SConst (I x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
10581134mkExp (SConst (BI x)) =
10591135 return $ InstanceCreation []
@@ -1080,226 +1156,235 @@ mkExp (SConst (PtrType)) = return $ mkClass objectType
10801156mkExp (SConst (VoidType)) = return $ mkClass voidType
10811157mkExp (SConst (Forgot)) = return $ mkClass objectType
10821158mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args
1083−mkExp (SOp LPlus args) = return $ mkBinOpExp integerType Add args
1084−mkExp (SOp LMinus args) = return $ mkBinOpExp integerType Sub args
1085−mkExp (SOp LTimes args) = return $ mkBinOpExp integerType Mult args
1086−mkExp (SOp LDiv args) = return $ mkBinOpExp integerType Div args
1087−mkExp (SOp LMod args) = return $ mkBinOpExp integerType Rem args
1088−mkExp (SOp LAnd args) = return $ mkBinOpExp integerType And args
1089−mkExp (SOp LOr args) = return $ mkBinOpExp integerType Or args
1090−mkExp (SOp LXOr args) = return $ mkBinOpExp integerType Xor args
1159+mkExp (SOp LPlus args) = mkBinOpExp integerType Add args
1160+mkExp (SOp LMinus args) = mkBinOpExp integerType Sub args
1161+mkExp (SOp LTimes args) = mkBinOpExp integerType Mult args
1162+mkExp (SOp LDiv args) = mkBinOpExp integerType Div args
1163+mkExp (SOp LMod args) = mkBinOpExp integerType Rem args
1164+mkExp (SOp LAnd args) = mkBinOpExp integerType And args
1165+mkExp (SOp LOr args) = mkBinOpExp integerType Or args
1166+mkExp (SOp LXOr args) = mkBinOpExp integerType Xor args
10911167mkExp (SOp LCompl [var]) =
1092− return $ PreBitCompl (mkVarAccess (Just $ integerType) var)
1093−mkExp (SOp LSHL args) = return $ mkBinOpExp integerType LShift args
1094−mkExp (SOp LSHR args) = return $ mkBinOpExp integerType RShift args
1168+ PreBitCompl <$> mkVarAccess (Just $ integerType) var
1169+mkExp (SOp LSHL args) = mkBinOpExp integerType LShift args
1170+mkExp (SOp LSHR args) = mkBinOpExp integerType RShift args
10951171mkExp (SOp LEq args) =
1096− return $ mkMethodOpChain1 (mkBoolToNumber integerType) objectType "equals" args
1097−mkExp (SOp LLt args) = return $ mkLogicalBinOpExp integerType LThan args
1098−mkExp (SOp LLe args) = return $ mkLogicalBinOpExp integerType LThanE args
1099−mkExp (SOp LGt args) = return $ mkLogicalBinOpExp integerType GThan args
1100−mkExp (SOp LGe args) = return $ mkLogicalBinOpExp integerType GThanE args
1101−mkExp (SOp LFPlus args) = return $ mkBinOpExp doubleType Add args
1102−mkExp (SOp LFMinus args) = return $ mkBinOpExp doubleType Sub args
1103−mkExp (SOp LFTimes args) = return $ mkBinOpExp doubleType Mult args
1104−mkExp (SOp LFDiv args) = return $ mkBinOpExp doubleType Div args
1172+ mkMethodOpChain1 (mkBoolToNumber integerType) objectType "equals" args
1173+mkExp (SOp LLt args) = mkLogicalBinOpExp integerType LThan args
1174+mkExp (SOp LLe args) = mkLogicalBinOpExp integerType LThanE args
1175+mkExp (SOp LGt args) = mkLogicalBinOpExp integerType GThan args
1176+mkExp (SOp LGe args) = mkLogicalBinOpExp integerType GThanE args
1177+mkExp (SOp LFPlus args) = mkBinOpExp doubleType Add args
1178+mkExp (SOp LFMinus args) = mkBinOpExp doubleType Sub args
1179+mkExp (SOp LFTimes args) = mkBinOpExp doubleType Mult args
1180+mkExp (SOp LFDiv args) = mkBinOpExp doubleType Div args
11051181mkExp (SOp LFEq args) =
1106− return $ mkMethodOpChain1 (mkBoolToNumber doubleType) doubleType "equals" args
1107−mkExp (SOp LFLt args) = return $ mkLogicalBinOpExp integerType LThan args
1108−mkExp (SOp LFLe args) = return $ mkLogicalBinOpExp integerType LThanE args
1109−mkExp (SOp LFGt args) = return $ mkLogicalBinOpExp integerType GThan args
1110−mkExp (SOp LFGe args) = return $ mkLogicalBinOpExp integerType GThanE args
1111−mkExp (SOp LBPlus args) = return $ mkMethodOpChain1 id bigIntegerType "add" args
1112−mkExp (SOp LBMinus args) = return $ mkMethodOpChain1 id bigIntegerType "subtract" args
1113−mkExp (SOp LBTimes args) = return $ mkMethodOpChain1 id bigIntegerType "multiply" args
1114−mkExp (SOp LBDiv args) = return $ mkMethodOpChain1 id bigIntegerType "divide" args
1115−mkExp (SOp LBMod args) = return $ mkMethodOpChain1 id bigIntegerType "mod" args
1182+ mkMethodOpChain1 (mkBoolToNumber doubleType) doubleType "equals" args
1183+mkExp (SOp LFLt args) = mkLogicalBinOpExp integerType LThan args
1184+mkExp (SOp LFLe args) = mkLogicalBinOpExp integerType LThanE args
1185+mkExp (SOp LFGt args) = mkLogicalBinOpExp integerType GThan args
1186+mkExp (SOp LFGe args) = mkLogicalBinOpExp integerType GThanE args
1187+mkExp (SOp LBPlus args) = mkMethodOpChain1 id bigIntegerType "add" args
1188+mkExp (SOp LBMinus args) = mkMethodOpChain1 id bigIntegerType "subtract" args
1189+mkExp (SOp LBTimes args) = mkMethodOpChain1 id bigIntegerType "multiply" args
1190+mkExp (SOp LBDiv args) = mkMethodOpChain1 id bigIntegerType "divide" args
1191+mkExp (SOp LBMod args) = mkMethodOpChain1 id bigIntegerType "mod" args
11161192mkExp (SOp LBEq args) =
1117− return $ mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args
1193+ mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args
11181194mkExp (SOp LBLt args) =
1119− return $ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1120− . mkPartialOrder SLt
1121− )
1122− bigIntegerType
1123− "compare"
1124− args
1195+ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1196+ . mkPartialOrder SLt
1197+ )
1198+ bigIntegerType
1199+ "compare"
1200+ args
11251201mkExp (SOp LBLe args) =
1126− return $ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1127− . mkPartialOrder SLe
1128− )
1129− bigIntegerType
1130− "compare"
1131− args
1202+ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1203+ . mkPartialOrder SLe
1204+ )
1205+ bigIntegerType
1206+ "compare"
1207+ args
11321208mkExp (SOp LBGt args) =
1133− return $ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1134− . mkPartialOrder SGt
1135− )
1136− bigIntegerType
1137− "compare"
1138− args
1209+ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1210+ . mkPartialOrder SGt
1211+ )
1212+ bigIntegerType
1213+ "compare"
1214+ args
11391215mkExp (SOp LBGe args) =
1140− return $ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1141− . mkPartialOrder SGe
1142− )
1143− bigIntegerType
1144− "compare"
1145− args
1216+ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1217+ . mkPartialOrder SGe
1218+ )
1219+ bigIntegerType
1220+ "compare"
1221+ args
11461222mkExp (SOp LStrConcat args) =
1147− return $ mkMethodOpChain (\ exp ->
1148− InstanceCreation []
1149− (ClassType [(Ident "StringBuilder", [])])
1150− [exp]
1151− Nothing
1152− )
1153− (\ exp -> MethodInv $ PrimaryMethodCall exp [] (Ident "toString") [])
1154− stringType
1155− "append"
1156− args
1223+ mkMethodOpChain (\ exp -> InstanceCreation []
1224+ (ClassType [(Ident "StringBuilder", [])])
1225+ [exp]
1226+ Nothing
1227+ )
1228+ (\ exp -> MethodInv $ PrimaryMethodCall exp [] (Ident "toString") [])
1229+ stringType
1230+ "append"
1231+ args
11571232mkExp (SOp LStrLt args@[_, _]) =
1158− return $ mkMethodOpChain1 ( mkBoolToNumber integerType
1159− . mkPartialOrder SLt
1160− )
1161− stringType
1162− "compare"
1163− args
1233+ mkMethodOpChain1 ( mkBoolToNumber integerType
1234+ . mkPartialOrder SLt
1235+ )
1236+ stringType
1237+ "compare"
1238+ args
11641239mkExp (SOp LStrEq args@[_, _]) =
1165− return $ mkMethodOpChain1 ( mkBoolToNumber integerType)
1166− stringType
1167− "equals"
1168− args
1240+ mkMethodOpChain1 ( mkBoolToNumber integerType)
1241+ stringType
1242+ "equals"
1243+ args
11691244mkExp (SOp LStrLen [arg]) =
1170− return . MethodInv $ PrimaryMethodCall (mkVarAccess (Just stringType) arg) [] (Ident "length") []
1245+ (\ var -> MethodInv $ PrimaryMethodCall var [] (Ident "length") [])
1246+ <$> mkVarAccess (Just stringType) arg
11711247mkExp (SOp LIntFloat [arg]) =
1172− return $ mkPrimitiveCast integerType doubleType arg
1248+ mkPrimitiveCast integerType doubleType arg
11731249mkExp (SOp LFloatInt [arg]) =
1174− return $ mkPrimitiveCast doubleType integerType arg
1250+ mkPrimitiveCast doubleType integerType arg
11751251mkExp (SOp LIntStr [arg]) =
1176− return $ mkToString integerType arg
1252+ mkToString integerType arg
11771253mkExp (SOp LStrInt [arg]) =
1178− return $ mkPrimitiveCast stringType integerType arg
1254+ mkPrimitiveCast stringType integerType arg
11791255mkExp (SOp LFloatStr [arg]) =
1180− return $ mkToString doubleType arg
1256+ mkToString doubleType arg
11811257mkExp (SOp LStrFloat [arg]) =
1182− return $ mkPrimitiveCast doubleType stringType arg
1258+ mkPrimitiveCast doubleType stringType arg
11831259mkExp (SOp LIntBig [arg]) =
1184− return $ mkPrimitiveCast integerType bigIntegerType arg
1260+ mkPrimitiveCast integerType bigIntegerType arg
11851261mkExp (SOp LBigInt [arg]) =
1186− return $ mkPrimitiveCast bigIntegerType integerType arg
1262+ mkPrimitiveCast bigIntegerType integerType arg
11871263mkExp (SOp LStrBig [arg]) =
1188− return $ InstanceCreation [] bigIntegerType [mkVarAccess (Just stringType) arg] Nothing
1264+ (\ var -> InstanceCreation [] bigIntegerType [var] Nothing)
1265+ <$> mkVarAccess (Just stringType) arg
11891266mkExp (SOp LBigStr [arg]) =
1190− return $ mkToString bigIntegerType arg
1267+ mkToString bigIntegerType arg
11911268mkExp (SOp LChInt [arg]) =
1192− return $ mkVarAccess (Just integerType) arg
1269+ mkVarAccess (Just integerType) arg
11931270mkExp (SOp LIntCh [arg]) =
1194− return $ mkVarAccess (Just integerType) arg
1271+ mkVarAccess (Just integerType) arg
11951272mkExp (SOp LPrintNum [arg]) =
1196− return $ mkSystemOutPrint (mkVarAccess Nothing arg)
1273+ mkSystemOutPrint <$> (mkVarAccess Nothing arg)
11971274mkExp (SOp LPrintStr [arg]) =
1198− return $ mkSystemOutPrint (mkVarAccess (Just stringType) arg)
1275+ mkSystemOutPrint <$> (mkVarAccess (Just stringType) arg)
11991276mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)])
1200−mkExp (SOp LB8Lt args) = return $ mkLogicalBinOpExp byteType LThan args
1201−mkExp (SOp LB8Lte args) = return $ mkLogicalBinOpExp byteType LThanE args
1277+mkExp (SOp LB8Lt args) = mkLogicalBinOpExp byteType LThan args
1278+mkExp (SOp LB8Lte args) = mkLogicalBinOpExp byteType LThanE args
12021279mkExp (SOp LB8Eq args) =
1203− return $ mkMethodOpChain1 (mkBoolToNumber byteType) byteType "equals" args
1204−mkExp (SOp LB8Gt args) = return $ mkLogicalBinOpExp byteType GThan args
1205−mkExp (SOp LB8Gte args) = return $ mkLogicalBinOpExp byteType GThanE args
1206−mkExp (SOp LB8Plus args) = return $ mkBinOpExp byteType Add args
1207−mkExp (SOp LB8Minus args) = return $ mkBinOpExp byteType Sub args
1208−mkExp (SOp LB8Times args) = return $ mkBinOpExp byteType Mult args
1209−mkExp (SOp LB8UDiv args) = return $ mkBinOpExpConv "shortValue" ShortT byteType Div args
1210−mkExp (SOp LB8SDiv args) = return $ mkBinOpExp byteType Div args
1211−mkExp (SOp LB8URem args) = return $ mkBinOpExpConv "shortValue" ShortT byteType Rem args
1212−mkExp (SOp LB8SRem args) = return $ mkBinOpExp byteType Rem args
1213−mkExp (SOp LB8Shl args) = return $ mkBinOpExp byteType LShift args
1214−mkExp (SOp LB8LShr args) = return $ mkBinOpExp byteType RRShift args
1215−mkExp (SOp LB8AShr args) = return $ mkBinOpExp byteType RShift args
1216−mkExp (SOp LB8And args) = return $ mkBinOpExp byteType And args
1217−mkExp (SOp LB8Or args) = return $ mkBinOpExp byteType Or args
1218−mkExp (SOp LB8Xor args) = return $ mkBinOpExp byteType Xor args
1280+ mkMethodOpChain1 (mkBoolToNumber byteType) byteType "equals" args
1281+mkExp (SOp LB8Gt args) = mkLogicalBinOpExp byteType GThan args
1282+mkExp (SOp LB8Gte args) = mkLogicalBinOpExp byteType GThanE args
1283+mkExp (SOp LB8Plus args) = mkBinOpExp byteType Add args
1284+mkExp (SOp LB8Minus args) = mkBinOpExp byteType Sub args
1285+mkExp (SOp LB8Times args) = mkBinOpExp byteType Mult args
1286+mkExp (SOp LB8UDiv args) = mkBinOpExpConv "shortValue" ShortT byteType Div args
1287+mkExp (SOp LB8SDiv args) = mkBinOpExp byteType Div args
1288+mkExp (SOp LB8URem args) = mkBinOpExpConv "shortValue" ShortT byteType Rem args
1289+mkExp (SOp LB8SRem args) = mkBinOpExp byteType Rem args
1290+mkExp (SOp LB8Shl args) = mkBinOpExp byteType LShift args
1291+mkExp (SOp LB8LShr args) = mkBinOpExp byteType RRShift args
1292+mkExp (SOp LB8AShr args) = mkBinOpExp byteType RShift args
1293+mkExp (SOp LB8And args) = mkBinOpExp byteType And args
1294+mkExp (SOp LB8Or args) = mkBinOpExp byteType Or args
1295+mkExp (SOp LB8Xor args) = mkBinOpExp byteType Xor args
12191296mkExp (SOp LB8Compl [var]) =
1220− return $ PreBitCompl (mkVarAccess (Just $ byteType) var)
1221−mkExp (SOp LB8Z16 [var]) = return $ mkZeroExt "shortValue" 8 byteType shortType var
1222−mkExp (SOp LB8Z32 [var]) = return $ mkZeroExt "intValue" 8 byteType integerType var
1223−mkExp (SOp LB8Z64 [var]) = return $ mkZeroExt "longValue" 8 byteType longType var
1224−mkExp (SOp LB8S16 [var]) = return $ mkSignedExt "shortValue" byteType shortType var
1225−mkExp (SOp LB8S32 [var]) = return $ mkSignedExt "intValue" byteType integerType var
1226−mkExp (SOp LB8S64 [var]) = return $ mkSignedExt "longValue" byteType longType var
1227−mkExp (SOp LB16Lt args) = return $ mkLogicalBinOpExp shortType LThan args
1228−mkExp (SOp LB16Lte args) = return $ mkLogicalBinOpExp shortType LThanE args
1297+ PreBitCompl <$> mkVarAccess (Just $ byteType) var
1298+mkExp (SOp LB8Z16 [var]) = mkZeroExt "shortValue" 8 byteType shortType var
1299+mkExp (SOp LB8Z32 [var]) = mkZeroExt "intValue" 8 byteType integerType var
1300+mkExp (SOp LB8Z64 [var]) = mkZeroExt "longValue" 8 byteType longType var
1301+mkExp (SOp LB8S16 [var]) = mkSignedExt "shortValue" byteType shortType var
1302+mkExp (SOp LB8S32 [var]) = mkSignedExt "intValue" byteType integerType var
1303+mkExp (SOp LB8S64 [var]) = mkSignedExt "longValue" byteType longType var
1304+mkExp (SOp LB16Lt args) = mkLogicalBinOpExp shortType LThan args
1305+mkExp (SOp LB16Lte args) = mkLogicalBinOpExp shortType LThanE args
12291306mkExp (SOp LB16Eq args) =
1230− return $ mkMethodOpChain1 (mkBoolToNumber shortType) shortType "equals" args
1231−mkExp (SOp LB16Gt args) = return $ mkLogicalBinOpExp shortType GThan args
1232−mkExp (SOp LB16Gte args) = return $ mkLogicalBinOpExp shortType GThanE args
1233−mkExp (SOp LB16Plus args) = return $ mkBinOpExp shortType Add args
1234−mkExp (SOp LB16Minus args) = return $ mkBinOpExp shortType Sub args
1235−mkExp (SOp LB16Times args) = return $ mkBinOpExp shortType Mult args
1236−mkExp (SOp LB16UDiv args) = return $ mkBinOpExpConv "intValue" IntT shortType Div args
1237−mkExp (SOp LB16SDiv args) = return $ mkBinOpExp shortType Div args
1238−mkExp (SOp LB16URem args) = return $ mkBinOpExpConv "intValue" IntT shortType Rem args
1239−mkExp (SOp LB16SRem args) = return $ mkBinOpExp shortType Rem args
1240−mkExp (SOp LB16Shl args) = return $ mkBinOpExp shortType LShift args
1241−mkExp (SOp LB16LShr args) = return $ mkBinOpExp shortType RRShift args
1242−mkExp (SOp LB16AShr args) = return $ mkBinOpExp shortType RShift args
1243−mkExp (SOp LB16And args) = return $ mkBinOpExp shortType And args
1244−mkExp (SOp LB16Or args) = return $ mkBinOpExp shortType Or args
1245−mkExp (SOp LB16Xor args) = return $ mkBinOpExp shortType Xor args
1307+ mkMethodOpChain1 (mkBoolToNumber shortType) shortType "equals" args
1308+mkExp (SOp LB16Gt args) = mkLogicalBinOpExp shortType GThan args
1309+mkExp (SOp LB16Gte args) = mkLogicalBinOpExp shortType GThanE args
1310+mkExp (SOp LB16Plus args) = mkBinOpExp shortType Add args
1311+mkExp (SOp LB16Minus args) = mkBinOpExp shortType Sub args
1312+mkExp (SOp LB16Times args) = mkBinOpExp shortType Mult args
1313+mkExp (SOp LB16UDiv args) = mkBinOpExpConv "intValue" IntT shortType Div args
1314+mkExp (SOp LB16SDiv args) = mkBinOpExp shortType Div args
1315+mkExp (SOp LB16URem args) = mkBinOpExpConv "intValue" IntT shortType Rem args
1316+mkExp (SOp LB16SRem args) = mkBinOpExp shortType Rem args
1317+mkExp (SOp LB16Shl args) = mkBinOpExp shortType LShift args
1318+mkExp (SOp LB16LShr args) = mkBinOpExp shortType RRShift args
1319+mkExp (SOp LB16AShr args) = mkBinOpExp shortType RShift args
1320+mkExp (SOp LB16And args) = mkBinOpExp shortType And args
1321+mkExp (SOp LB16Or args) = mkBinOpExp shortType Or args
1322+mkExp (SOp LB16Xor args) = mkBinOpExp shortType Xor args
12461323mkExp (SOp LB16Compl [var]) =
1247− return $ PreBitCompl (mkVarAccess (Just $ shortType) var)
1248−mkExp (SOp LB16Z32 [var]) = return $ mkZeroExt "intValue" 16 shortType integerType var
1249−mkExp (SOp LB16Z64 [var]) = return $ mkZeroExt "longValue" 16 shortType longType var
1250−mkExp (SOp LB16S32 [var]) = return $ mkSignedExt "intValue" shortType integerType var
1251−mkExp (SOp LB16S64 [var]) = return $ mkSignedExt "longValue" shortType longType var
1324+ PreBitCompl <$> mkVarAccess (Just $ shortType) var
1325+mkExp (SOp LB16Z32 [var]) = mkZeroExt "intValue" 16 shortType integerType var
1326+mkExp (SOp LB16Z64 [var]) = mkZeroExt "longValue" 16 shortType longType var
1327+mkExp (SOp LB16S32 [var]) = mkSignedExt "intValue" shortType integerType var
1328+mkExp (SOp LB16S64 [var]) = mkSignedExt "longValue" shortType longType var
12521329mkExp (SOp LB16T8 [var]) =
1253− return . MethodInv $
1254− TypeMethodCall (J.Name [Ident "Byte"])
1255− []
1256− (Ident "valueOf")
1257− [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ shortType) var) [] (Ident "byteValue") [] ]
1258−mkExp (SOp LB32Lt args) = return $ mkLogicalBinOpExp integerType LThan args
1259−mkExp (SOp LB32Lte args) = return $ mkLogicalBinOpExp integerType LThanE args
1330+ (\ var -> MethodInv $
1331+ TypeMethodCall (J.Name [Ident "Byte"])
1332+ []
1333+ (Ident "valueOf")
1334+ [ MethodInv
1335+ $ PrimaryMethodCall var [] (Ident "byteValue") [] ]
1336+ )
1337+ <$> mkVarAccess (Just $ shortType) var
1338+mkExp (SOp LB32Lt args) = mkLogicalBinOpExp integerType LThan args
1339+mkExp (SOp LB32Lte args) = mkLogicalBinOpExp integerType LThanE args
12601340mkExp (SOp LB32Eq args) =
1261− return $ mkMethodOpChain1 (mkBoolToNumber integerType) integerType "equals" args
1262−mkExp (SOp LB32Gt args) = return $ mkLogicalBinOpExp integerType GThan args
1263−mkExp (SOp LB32Gte args) = return $ mkLogicalBinOpExp integerType GThanE args
1264−mkExp (SOp LB32Plus args) = return $ mkBinOpExp integerType Add args
1265−mkExp (SOp LB32Minus args) = return $ mkBinOpExp integerType Sub args
1266−mkExp (SOp LB32Times args) = return $ mkBinOpExp integerType Mult args
1267−mkExp (SOp LB32UDiv args) = return $ mkBinOpExpConv "longValue" LongT integerType Div args
1268−mkExp (SOp LB32SDiv args) = return $ mkBinOpExp integerType Div args
1269−mkExp (SOp LB32URem args) = return $ mkBinOpExpConv "longValue" LongT integerType Rem args
1270−mkExp (SOp LB32SRem args) = return $ mkBinOpExp integerType Rem args
1271−mkExp (SOp LB32Shl args) = return $ mkBinOpExp integerType LShift args
1272−mkExp (SOp LB32LShr args) = return $ mkBinOpExp integerType RRShift args
1273−mkExp (SOp LB32AShr args) = return $ mkBinOpExp integerType RShift args
1274−mkExp (SOp LB32And args) = return $ mkBinOpExp integerType And args
1275−mkExp (SOp LB32Or args) = return $ mkBinOpExp integerType Or args
1276−mkExp (SOp LB32Xor args) = return $ mkBinOpExp integerType Xor args
1341+ mkMethodOpChain1 (mkBoolToNumber integerType) integerType "equals" args
1342+mkExp (SOp LB32Gt args) = mkLogicalBinOpExp integerType GThan args
1343+mkExp (SOp LB32Gte args) = mkLogicalBinOpExp integerType GThanE args
1344+mkExp (SOp LB32Plus args) = mkBinOpExp integerType Add args
1345+mkExp (SOp LB32Minus args) = mkBinOpExp integerType Sub args
1346+mkExp (SOp LB32Times args) = mkBinOpExp integerType Mult args
1347+mkExp (SOp LB32UDiv args) = mkBinOpExpConv "longValue" LongT integerType Div args
1348+mkExp (SOp LB32SDiv args) = mkBinOpExp integerType Div args
1349+mkExp (SOp LB32URem args) = mkBinOpExpConv "longValue" LongT integerType Rem args
1350+mkExp (SOp LB32SRem args) = mkBinOpExp integerType Rem args
1351+mkExp (SOp LB32Shl args) = mkBinOpExp integerType LShift args
1352+mkExp (SOp LB32LShr args) = mkBinOpExp integerType RRShift args
1353+mkExp (SOp LB32AShr args) = mkBinOpExp integerType RShift args
1354+mkExp (SOp LB32And args) = mkBinOpExp integerType And args
1355+mkExp (SOp LB32Or args) = mkBinOpExp integerType Or args
1356+mkExp (SOp LB32Xor args) = mkBinOpExp integerType Xor args
12771357mkExp (SOp LB32Compl [var]) =
1278− return $ PreBitCompl (mkVarAccess (Just $ integerType) var)
1279−mkExp (SOp LB32Z64 [var]) = return $ mkZeroExt "longValue" 32 integerType longType var
1280−mkExp (SOp LB32S64 [var]) = return $ mkSignedExt "longValue" integerType longType var
1358+ PreBitCompl <$> mkVarAccess (Just $ integerType) var
1359+mkExp (SOp LB32Z64 [var]) = mkZeroExt "longValue" 32 integerType longType var
1360+mkExp (SOp LB32S64 [var]) = mkSignedExt "longValue" integerType longType var
12811361mkExp (SOp LB32T8 [var]) =
1282− return . MethodInv $
1283− TypeMethodCall (J.Name [Ident "Byte"])
1284− []
1285− (Ident "valueOf")
1286− [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ integerType) var) [] (Ident "byteValue") [] ]
1362+ (\ var -> MethodInv
1363+ $ TypeMethodCall (J.Name [Ident "Byte"])
1364+ []
1365+ (Ident "valueOf")
1366+ [ MethodInv $ PrimaryMethodCall var [] (Ident "byteValue") [] ]
1367+ )
1368+ <$> mkVarAccess (Just $ integerType) var
12871369mkExp (SOp LB32T16 [var]) =
1288− return . MethodInv $
1289− TypeMethodCall (J.Name [Ident "Short"])
1290− []
1291− (Ident "valueOf")
1292− [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ integerType) var) [] (Ident "shortValue") [] ]
1293−mkExp (SOp LB64Lt args) = return $ mkLogicalBinOpExp longType LThan args
1294−mkExp (SOp LB64Lte args) = return $ mkLogicalBinOpExp longType LThanE args
1370+ (\ var -> MethodInv
1371+ $ TypeMethodCall (J.Name [Ident "Short"])
1372+ []
1373+ (Ident "valueOf")
1374+ [ MethodInv $ PrimaryMethodCall var [] (Ident "shortValue") [] ]
1375+ )
1376+ <$> mkVarAccess (Just $ integerType) var
1377+mkExp (SOp LB64Lt args) = mkLogicalBinOpExp longType LThan args
1378+mkExp (SOp LB64Lte args) = mkLogicalBinOpExp longType LThanE args
12951379mkExp (SOp LB64Eq args) =
1296− return $ mkMethodOpChain1 (mkBoolToNumber longType) longType "equals" args
1297−mkExp (SOp LB64Gt args) = return $ mkLogicalBinOpExp longType GThan args
1298−mkExp (SOp LB64Gte args) = return $ mkLogicalBinOpExp longType GThanE args
1299−mkExp (SOp LB64Plus args) = return $ mkBinOpExp longType Add args
1300−mkExp (SOp LB64Minus args) = return $ mkBinOpExp longType Sub args
1301−mkExp (SOp LB64Times args) = return $ mkBinOpExp longType Mult args
1302−mkExp (SOp LB64UDiv (arg:args)) =
1380+ mkMethodOpChain1 (mkBoolToNumber longType) longType "equals" args
1381+mkExp (SOp LB64Gt args) = mkLogicalBinOpExp longType GThan args
1382+mkExp (SOp LB64Gte args) = mkLogicalBinOpExp longType GThanE args
1383+mkExp (SOp LB64Plus args) = mkBinOpExp longType Add args
1384+mkExp (SOp LB64Minus args) = mkBinOpExp longType Sub args
1385+mkExp (SOp LB64Times args) = mkBinOpExp longType Mult args
1386+mkExp (SOp LB64UDiv (arg:args)) = do
1387+ (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
13031388 return $ foldl (\ exp arg ->
13041389 MethodInv $ PrimaryMethodCall
13051390 ( MethodInv $ PrimaryMethodCall
@@ -1313,17 +1398,18 @@ mkExp (SOp LB64UDiv (arg:args)) =
13131398 [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
13141399 []
13151400 (Ident "valueOf")
1316− [ (mkVarAccess (Just longType) arg) ]
1401+ [ arg ]
13171402 ]
13181403 )
13191404 []
13201405 (Ident "longValue")
13211406 []
13221407 )
1323− (mkVarAccess (Just longType) arg)
1408+ arg
13241409 args
1325−mkExp (SOp LB64SDiv args) = return $ mkBinOpExp longType Div args
1326−mkExp (SOp LB64URem (arg:args)) =
1410+mkExp (SOp LB64SDiv args) = mkBinOpExp longType Div args
1411+mkExp (SOp LB64URem (arg:args)) = do
1412+ (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
13271413 return $ foldl (\ exp arg ->
13281414 MethodInv $ PrimaryMethodCall
13291415 ( MethodInv $ PrimaryMethodCall
@@ -1337,69 +1423,79 @@ mkExp (SOp LB64URem (arg:args)) =
13371423 [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
13381424 []
13391425 (Ident "valueOf")
1340− [ (mkVarAccess (Just longType) arg) ]
1426+ [ arg ]
13411427 ]
13421428 )
13431429 []
13441430 (Ident "longValue")
13451431 []
13461432 )
1347− (mkVarAccess (Just longType) arg)
1433+ arg
13481434 args
1349−mkExp (SOp LB64SRem args) = return $ mkBinOpExp longType Rem args
1350−mkExp (SOp LB64Shl args) = return $ mkBinOpExp longType LShift args
1351−mkExp (SOp LB64LShr args) = return $ mkBinOpExp longType RRShift args
1352−mkExp (SOp LB64AShr args) = return $ mkBinOpExp longType RShift args
1353−mkExp (SOp LB64And args) = return $ mkBinOpExp longType And args
1354−mkExp (SOp LB64Or args) = return $ mkBinOpExp longType Or args
1355−mkExp (SOp LB64Xor args) = return $ mkBinOpExp longType Xor args
1435+mkExp (SOp LB64SRem args) = mkBinOpExp longType Rem args
1436+mkExp (SOp LB64Shl args) = mkBinOpExp longType LShift args
1437+mkExp (SOp LB64LShr args) = mkBinOpExp longType RRShift args
1438+mkExp (SOp LB64AShr args) = mkBinOpExp longType RShift args
1439+mkExp (SOp LB64And args) = mkBinOpExp longType And args
1440+mkExp (SOp LB64Or args) = mkBinOpExp longType Or args
1441+mkExp (SOp LB64Xor args) = mkBinOpExp longType Xor args
13561442mkExp (SOp LB64Compl [var]) =
1357− return $ PreBitCompl (mkVarAccess (Just $ longType) var)
1443+ PreBitCompl <$> mkVarAccess (Just $ longType) var
13581444mkExp (SOp LB64T8 [var]) =
1359− return . MethodInv $
1360− TypeMethodCall (J.Name [Ident "Byte"])
1361− []
1362− (Ident "valueOf")
1363− [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ longType) var) [] (Ident "byteValue") [] ]
1445+ (\ var -> MethodInv
1446+ $ TypeMethodCall (J.Name [Ident "Byte"])
1447+ []
1448+ (Ident "valueOf")
1449+ [ MethodInv
1450+ $ PrimaryMethodCall var [] (Ident "byteValue") []
1451+ ]
1452+ )
1453+ <$> mkVarAccess (Just $ longType) var
13641454mkExp (SOp LB64T16 [var]) =
1365− return . MethodInv $
1366− TypeMethodCall (J.Name [Ident "Short"])
1367− []
1368− (Ident "valueOf")
1369− [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ longType) var) [] (Ident "shortValue") [] ]
1455+ (\ var -> MethodInv
1456+ $ TypeMethodCall (J.Name [Ident "Short"])
1457+ []
1458+ (Ident "valueOf")
1459+ [ MethodInv $ PrimaryMethodCall var [] (Ident "shortValue") [] ]
1460+ )
1461+ <$> mkVarAccess (Just $ longType) var
13701462mkExp (SOp LB64T32 [var]) =
1371− return . MethodInv $
1372− TypeMethodCall (J.Name [Ident "Integer"])
1373− []
1374− (Ident "valueOf")
1375− [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ longType) var) [] (Ident "intValue") [] ]
1463+ (\ var -> MethodInv
1464+ $ TypeMethodCall (J.Name [Ident "Integer"])
1465+ []
1466+ (Ident "valueOf")
1467+ [ MethodInv $ PrimaryMethodCall var [] (Ident "intValue") [] ]
1468+ )
1469+ <$> mkVarAccess (Just $ longType) var
13761470mkExp (SOp LIntB8 [arg]) = mkExp (SOp LB32T8 [arg])
13771471mkExp (SOp LIntB16 [arg]) = mkExp (SOp LB32T16 [arg])
13781472mkExp (SOp LIntB32 [arg]) = mkExp (SV arg)
13791473mkExp (SOp LIntB64 [arg]) = mkExp (SOp LB32S64 [arg])
13801474mkExp (SOp LB32Int [arg]) = mkExp (SV arg)
1381−mkExp (SOp LFExp [arg]) = return $ mkMathFun "exp" arg
1382−mkExp (SOp LFLog [arg]) = return $ mkMathFun "log" arg
1383−mkExp (SOp LFSin [arg]) = return $ mkMathFun "sin" arg
1384−mkExp (SOp LFCos [arg]) = return $ mkMathFun "cos" arg
1385−mkExp (SOp LFTan [arg]) = return $ mkMathFun "tan" arg
1386−mkExp (SOp LFASin [arg]) = return $ mkMathFun "asin" arg
1387−mkExp (SOp LFACos [arg]) = return $ mkMathFun "acos" arg
1388−mkExp (SOp LFATan [arg]) = return $ mkMathFun "atan" arg
1389−mkExp (SOp LFSqrt [arg]) = return $ mkMathFun "sqrt" arg
1390−mkExp (SOp LFFloor [arg]) = return $ mkMathFun "floor" arg
1391−mkExp (SOp LFCeil [arg]) = return $ mkMathFun "ceil" arg
1392−mkExp (SOp LStrHead [arg]) = return $ mkStringAtIndex arg (Lit $ Int 0)
1475+mkExp (SOp LFExp [arg]) = mkMathFun "exp" arg
1476+mkExp (SOp LFLog [arg]) = mkMathFun "log" arg
1477+mkExp (SOp LFSin [arg]) = mkMathFun "sin" arg
1478+mkExp (SOp LFCos [arg]) = mkMathFun "cos" arg
1479+mkExp (SOp LFTan [arg]) = mkMathFun "tan" arg
1480+mkExp (SOp LFASin [arg]) = mkMathFun "asin" arg
1481+mkExp (SOp LFACos [arg]) = mkMathFun "acos" arg
1482+mkExp (SOp LFATan [arg]) = mkMathFun "atan" arg
1483+mkExp (SOp LFSqrt [arg]) = mkMathFun "sqrt" arg
1484+mkExp (SOp LFFloor [arg]) = mkMathFun "floor" arg
1485+mkExp (SOp LFCeil [arg]) = mkMathFun "ceil" arg
1486+mkExp (SOp LStrHead [arg]) = mkStringAtIndex arg (Lit $ Int 0)
13931487mkExp (SOp LStrTail [arg]) =
1394− return . MethodInv $ PrimaryMethodCall (mkVarAccess (Just stringType) arg)
1488+ (\ var -> MethodInv $ PrimaryMethodCall (var)
13951489 []
13961490 (Ident "substring")
13971491 [Lit $ Int 1]
1492+ )
1493+ <$> mkVarAccess (Just stringType) arg
13981494mkExp (SOp LStrCons [c, cs]) =
1399− return . MethodInv $
1495+ (\ cVar csVar -> MethodInv $
14001496 PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
14011497 (ClassType [(Ident "StringBuilder", [])])
1402− [mkVarAccess (Just stringType) cs]
1498+ [csVar]
14031499 Nothing
14041500 )
14051501 []
@@ -1407,7 +1503,7 @@ mkExp (SOp LStrCons [c, cs]) =
14071503 [ Lit $ Int 0,
14081504 Cast (PrimType CharT)
14091505 (MethodInv $ PrimaryMethodCall
1410− (mkVarAccess (Just integerType) c)
1506+ (cVar)
14111507 []
14121508 (Ident "intValue")
14131509 []
@@ -1417,12 +1513,15 @@ mkExp (SOp LStrCons [c, cs]) =
14171513 []
14181514 (Ident "toString")
14191515 []
1420−mkExp (SOp LStrIndex [str, i]) = return $ mkStringAtIndex str (mkVarAccess (Just integerType) i)
1516+ )
1517+ <$> mkVarAccess (Just integerType) c
1518+ <*> mkVarAccess (Just stringType) cs
1519+mkExp (SOp LStrIndex [str, i]) = mkVarAccess (Just integerType) i >>= mkStringAtIndex str
14211520mkExp (SOp LStrRev [str]) =
1422− return . MethodInv $
1521+ (\ var -> MethodInv $
14231522 PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
14241523 (ClassType [(Ident "StringBuffer", [])])
1425− [mkVarAccess (Just stringType) str]
1524+ [var]
14261525 Nothing
14271526 )
14281527 []
@@ -1432,13 +1531,15 @@ mkExp (SOp LStrRev [str]) =
14321531 []
14331532 (Ident "toString")
14341533 []
1534+ )
1535+ <$> mkVarAccess (Just stringType) str
14351536mkExp (SOp LStdIn []) = return $ mkSystemStd In
14361537mkExp (SOp LStdOut []) = return $ mkSystemStd Out
14371538mkExp (SOp LStdErr []) = return $ mkSystemStd Err
14381539mkExp (SOp LFork [arg]) = mkThread arg
14391540mkExp (SOp LPar [arg]) = mkExp (SV arg)
14401541mkExp (SOp LVMPtr []) =
1441− return . MethodInv $ TypeMethodCall (J.Name [Ident "Thread"]) [] (Ident "currentThread") []
1542+ return $ MethodInv $ TypeMethodCall (J.Name [Ident "Thread"]) [] (Ident "currentThread") []
14421543mkExp (SOp LNoOp args) = mkExp . SV $ last args
14431544mkExp (SNothing) = return $ Lit Null
14441545mkExp (SError err) =