git.iko.soy/Idris-dev
on 0f49abc help sign in
Idris-dev/src/IRTS/CodegenJava.hs
1462 lines 68 kB history raw
1module IRTS.CodegenJava (codegenJava) where
3import Core.TT
4import IRTS.BCImp
5import IRTS.CodegenCommon
6import IRTS.Lang
7import IRTS.Simplified
8import Paths_idris
9import Util.System
11import Control.Applicative
12import Control.Arrow
13import Control.Monad
14import Data.Char
15import Data.Maybe (fromJust)
16import Language.Java.Parser
17import Language.Java.Pretty
18import Language.Java.Syntax hiding (Name)
19import qualified Language.Java.Syntax as J
20import System.Directory
21import System.Exit
22import System.FilePath
23import System.IO
24import System.Process
26codegenJava :: [(Name, SDecl)] ->
27 FilePath -> -- output file name
28 OutputType ->
29 IO ()
30codegenJava defs out exec =
31 either (error)
32 (writeFile out . flatIndent . prettyPrint)
33 (mkCompilationUnit defs out)
35mkCompilationUnit :: [(Name, SDecl)] ->
36 FilePath ->
37 Either String CompilationUnit
38mkCompilationUnit defs out =
39 CompilationUnit Nothing [ ImportDecl False idrisRts True
40 , ImportDecl True idrisForeign True
41 , ImportDecl False bigInteger False
42 , ImportDecl False stringBuffer False
43 , ImportDecl False runtimeException False
44 , ImportDecl False scanner False
45 , ImportDecl False arrays False
46 ] <$>
47 mkTypeDecl defs out
48 where
49 idrisRts = J.Name $ map Ident ["org", "idris", "rts"]
50 idrisForeign = J.Name $ map Ident ["org", "idris", "rts", "ForeignPrimitives"]
51 bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]
52 stringBuffer = J.Name $ map Ident ["java", "lang", "StringBuffer"]
53 runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]
54 scanner = J.Name $ map Ident ["java", "util", "Scanner"]
55 arrays = J.Name $ map Ident ["java", "util", "Arrays"]
57flatIndent :: String -> String
58flatIndent (' ' : ' ' : xs) = flatIndent xs
59flatIndent (x:xs) = x:flatIndent xs
60flatIndent [] = []
62prefixCallNamespaces :: Ident -> SExp -> SExp
63prefixCallNamespaces (Ident name) (SApp tail (NS n ns) args) = SApp tail (NS n (name:ns)) args
64prefixCallNamespaces name (SLet var e1 e2) = SLet var (prefixCallNamespaces name e1) (prefixCallNamespaces name e2)
65prefixCallNamespaces name (SUpdate var e) = SUpdate var (prefixCallNamespaces name e)
66prefixCallNamespaces name (SCase var alts) = SCase var (map (prefixCallNamespacesCase name) alts)
67prefixCallNamespaces name (SChkCase var alts) = SChkCase var (map (prefixCallNamespacesCase name) alts)
68prefixCallNamespaces _ exp = exp
70prefixCallNamespacesCase :: Ident -> SAlt -> SAlt
71prefixCallNamespacesCase name (SConCase x y n ns e) = SConCase x y n ns (prefixCallNamespaces name e)
72prefixCallNamespacesCase name (SConstCase c e) = SConstCase c (prefixCallNamespaces name e)
73prefixCallNamespacesCase name (SDefaultCase e) = SDefaultCase (prefixCallNamespaces name e)
75prefixCallNamespacesDecl :: Ident -> SDecl -> SDecl
76prefixCallNamespacesDecl name (SFun fname args i e) = SFun fname args i (prefixCallNamespaces name e)
78mkTypeDecl :: [(Name, SDecl)] ->
79 FilePath ->
80 Either String [TypeDecl]
81mkTypeDecl defs out =
82 (\ name body -> [ClassTypeDecl $ ClassDecl [ Public
83 , Annotation $ SingleElementAnnotation
84 (J.Name [Ident "SuppressWarnings"])
85 (EVVal . InitExp . Lit $ String "unchecked")
86 ]
87 name
88 []
89 Nothing
90 []
91 body])
92 <$> mkClassName out
93 <*> ( mkClassName out
94 >>= (\ ident -> mkClassBody (map (second (prefixCallNamespacesDecl ident)) defs))
95 )
97mkClassName :: FilePath -> Either String Ident
98mkClassName path =
99 left (\ err -> "Parser error in \"" ++ path ++ "\": " ++ (show err))
100 (parser ident . takeBaseName $ takeFileName path)
102mkClassBody :: [(Name, SDecl)] ->
103 Either String ClassBody
104mkClassBody defs = (ClassBody . addMainMethod . mergeInnerClasses)
105 <$> mapM mkDecl defs
107addMainMethod :: [Decl] -> [Decl]
108addMainMethod decls
109 | findMain decls = mkMainMethod : decls
110 | otherwise = decls
111 where
112 findMain ((MemberDecl (MemberClassDecl (ClassDecl _ (Ident "Main") _ _ _ (ClassBody body)))):_) =
113 findMainMethod body
114 findMain (_:decls) = findMain decls
115 findMain [] = False
117 findMainMethod ((MemberDecl (MethodDecl _ _ _ (Ident "main") [] _ _)):_) = True
118 findMainMethod (_:decls) = findMainMethod decls
119 findMainMethod [] = False
121mkMainMethod :: Decl
122mkMainMethod =
123 MemberDecl $ MethodDecl [Public, Static]
124 []
125 Nothing
126 (Ident "main")
127 [FormalParam [] stringArrayType False (VarId $ Ident "args")]
128 []
129 (MethodBody . Just $ Block [ BlockStmt . ExpStmt . MethodInv $
130 MethodCall (J.Name [Ident "idris_initArgs"])
131 [ MethodInv $ TypeMethodCall
132 (J.Name [Ident "Thread"])
133 []
134 (Ident "currentThread")
135 []
136 , ExpName $ J.Name [Ident "args"]
137 ]
138 , BlockStmt . ExpStmt . MethodInv $
139 MethodCall (J.Name [Ident "runMain_0"])
140 []
141 ]
142 )
144mergeInnerClasses :: [Decl] -> [Decl]
145mergeInnerClasses = foldl mergeInner []
146 where
147 mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls)
148 decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body'))))
149 | name == name' =
150 (MemberDecl $ MemberClassDecl $
151 ClassDecl priv
152 name
153 targs
154 (mplus ext ext')
155 (imp ++ imp')
156 (ClassBody $ mergeInnerClasses (body ++ body')))
157 : decls
158 | otherwise = decl:(mergeInner decls decl')
159 mergeInner (decl:decls) decl' = decl:(mergeInner decls decl')
160 mergeInner [] decl' = [decl']
163mkIdentifier :: Name -> Either String Ident
164mkIdentifier (NS name _) = mkIdentifier name
165mkIdentifier (MN i name) = (\ (Ident x) -> Ident $ x ++ ('_' : show i))
166 <$> mkIdentifier (UN name)
167mkIdentifier (UN name) =
168 left (\ err -> "Parser error in \"" ++ name ++ "\": " ++ (show err))
169 ( parser ident
170 . cleanReserved
171 . cleanNonLetter
172 . cleanStart
173 $ cleanWs False name)
174 where
175 cleanStart (x:xs)
176 | isNumber x = '_' : (x:xs)
177 | otherwise = (x:xs)
178 cleanStart [] = []
179 cleanNonLetter (x:xs)
180 | x == '#' = "_Hash" ++ cleanNonLetter xs
181 | x == '@' = "_At" ++ cleanNonLetter xs
182 | x == '$' = "_Dollar" ++ cleanNonLetter xs
183 | x == '!' = "_Bang" ++ cleanNonLetter xs
184 | x == '.' = "_Dot" ++ cleanNonLetter xs
185 | x == '\'' = "_Prime" ++ cleanNonLetter xs
186 | x == '*' = "_Times" ++ cleanNonLetter xs
187 | x == '+' = "_Plus" ++ cleanNonLetter xs
188 | x == '/' = "_Divide" ++ cleanNonLetter xs
189 | x == '-' = "_Minus" ++ cleanNonLetter xs
190 | x == '%' = "_Mod" ++ cleanNonLetter xs
191 | x == '<' = "_LessThan" ++ cleanNonLetter xs
192 | x == '=' = "_Equals" ++ cleanNonLetter xs
193 | x == '>' = "_MoreThan" ++ cleanNonLetter xs
194 | x == '[' = "_LSBrace" ++ cleanNonLetter xs
195 | x == ']' = "_RSBrace" ++ cleanNonLetter xs
196 | x == '(' = "_LBrace" ++ cleanNonLetter xs
197 | x == ')' = "_RBrace" ++ cleanNonLetter xs
198 | x == '_' = "__" ++ cleanNonLetter xs
199 | not (isAlphaNum x) = "_" ++ (show $ ord x) ++ xs
200 | otherwise = x:cleanNonLetter xs
201 cleanNonLetter [] = []
202 cleanWs capitalize (x:xs)
203 | isSpace x = cleanWs True xs
204 | capitalize = (toUpper x) : (cleanWs False xs)
205 | otherwise = x : (cleanWs False xs)
206 cleanWs _ [] = []
209 cleanReserved "param" = "_param"
210 cleanReserved "context" = "_context"
211 cleanReserved "newcontext" = "_newcontext"
213 cleanReserved "void" = "_void"
214 cleanReserved "null" = "_null"
215 cleanReserved "int" = "_int"
216 cleanReserved "long" = "_long"
217 cleanReserved "char" = "_char"
218 cleanReserved "byte" = "_byte"
219 cleanReserved "double" = "_double"
220 cleanReserved "float" = "_float"
221 cleanReserved "boolean" = "_boolean"
222 cleanReserved "Object" = "_Object"
223 cleanReserved "String" = "_String"
224 cleanReserved "StringBuilder" = "_StringBuilder"
225 cleanReserved "StringBuffer" = "_StringBuffer"
226 cleanReserved "Scanner" = "_Scanner"
227 cleanReserved "Integer" = "_Integer"
228 cleanReserved "Double" = "_Double"
229 cleanReserved "Byte" = "_Byte"
230 cleanReserved "Character" = "_Character"
231 cleanReserved "BigInteger" = "_BigInteger"
232 cleanReserved "Boolean" = "_Boolean"
233 cleanReserved "Closure" = "_Closure"
234 cleanReserved "IdrisObject" = "_IdrisObject"
235 cleanReserved "TailCallClosure" = "_TailCallClosure"
236 cleanReserved "System" = "_System"
237 cleanReserved "Math" = "_Math"
238 cleanReserved "Arrays" = "_Arrays"
239 cleanReserved "RuntimeException" = "_RuntimeException"
240 cleanReserved "Comparable" = "_Comparable"
242 cleanReserved "class" = "_class"
243 cleanReserved "enum" = "_enum"
244 cleanReserved "interface" = "_interface"
245 cleanReserved "extends" = "_extends"
246 cleanReserved "implements" = "_implements"
247 cleanReserved "public" = "_public"
248 cleanReserved "private" = "_private"
249 cleanReserved "protected" = "_protected"
250 cleanReserved "static" = "_static"
251 cleanReserved "final" = "_final"
252 cleanReserved "abstract" = "_abstract"
253 cleanReserved "strict" = "_strict"
254 cleanReserved "volatile" = "_volatile"
255 cleanReserved "transient" = "_transient"
256 cleanReserved "native" = "_native"
258 cleanReserved "import" = "_import"
259 cleanReserved "package" = "_package"
261 cleanReserved "throw" = "_throw"
262 cleanReserved "throws" = "_throws"
263 cleanReserved "try" = "_try"
264 cleanReserved "catch" = "_catch"
266 cleanReserved "synchronized" = "_synchronized"
268 cleanReserved "if" = "_if"
269 cleanReserved "else" = "_else"
270 cleanReserved "switch" = "_switch"
271 cleanReserved "case" = "_case"
272 cleanReserved "default" = "_default"
274 cleanReserved "while" = "_while"
275 cleanReserved "for" = "_for"
276 cleanReserved "do" = "_do"
277 cleanReserved "break" = "_break"
278 cleanReserved "continue" = "_continue"
279 cleanReserved "goto" = "_goto"
281 cleanReserved "this" = "_this"
282 cleanReserved "super" = "_super"
283 cleanReserved "new" = "_new"
284 cleanReserved "return" = "_return"
286 cleanReserved "idris_initArgs" = "_idris_initArgs"
287 cleanReserved "idris_numArgs" = "_idris_numArgs"
288 cleanReserved "idris_getArg" = "_idris_getArg"
289 cleanReserved "getenv" = "_getenv"
290 cleanReserved "exit" = "_exit"
291 cleanReserved "usleep" = "_usleep"
292 cleanReserved "idris_sendMessage" = "_idris_sendMessage"
293 cleanReserved "idris_checkMessage" = "_idris_checkMessage"
294 cleanReserved "idris_recvMessage" = "_idris_recvMessage"
295 cleanReserved "putStr" = "_putStr"
296 cleanReserved "putchar" = "_putchar"
297 cleanReserved "getchar" = "_getchar"
298 cleanReserved "fileOpen" = "_fileOpen"
299 cleanReserved "fileClose" = "_fileClose"
300 cleanReserved "fputStr" = "_fputStr"
301 cleanReserved "fileEOF" = "_fileEOF"
302 cleanReserved "isNull" = "_isNull"
304 cleanReserved x = x
306mkName :: Name -> Either String J.Name
307mkName (NS name nss) = (\ n ns -> J.Name (n:ns))
308 <$> mkIdentifier name
309 <*> mapM (mkIdentifier . UN) nss
310mkName n = J.Name . (:[]) <$> mkIdentifier n
312voidType :: ClassType
313voidType = ClassType [(Ident "Void", [])]
315objectType :: ClassType
316objectType = ClassType [(Ident "Object", [])]
318objectArrayType :: Language.Java.Syntax.Type
319objectArrayType = RefType . ArrayType . RefType . ClassRefType $ objectType
321idrisClosureType :: ClassType
322idrisClosureType = ClassType [(Ident "Closure", [])]
324idrisTailCallClosureType :: ClassType
325idrisTailCallClosureType = ClassType [(Ident "TailCallClosure", [])]
327--idrisFunctionType :: ClassType
328--idrisFunctionType = ClassType [(Ident "IdrisFunction", [])]
330idrisObjectType :: ClassType
331idrisObjectType = ClassType [(Ident "IdrisObject", [])]
333contextArray :: Exp
334contextArray = ExpName $ J.Name [Ident "context"]
336charType :: ClassType
337charType = ClassType [(Ident "Character", [])]
339byteType :: ClassType
340byteType = ClassType [(Ident "Byte", [])]
342shortType :: ClassType
343shortType = ClassType [(Ident "Short", [])]
345integerType :: ClassType
346integerType = ClassType [(Ident "Integer", [])]
348longType :: ClassType
349longType = ClassType [(Ident "Integer", [])]
351bigIntegerType :: ClassType
352bigIntegerType = ClassType [(Ident "BigInteger", [])]
354doubleType :: ClassType
355doubleType = ClassType [(Ident "Double", [])]
357stringType :: ClassType
358stringType = ClassType [(Ident "String", [])]
360stringArrayType :: Language.Java.Syntax.Type
361stringArrayType = RefType . ArrayType . RefType . ClassRefType $ stringType
363exceptionType :: ClassType
364exceptionType = ClassType [(Ident "Throwable", [])]
366runtimeExceptionType :: ClassType
367runtimeExceptionType = ClassType [(Ident "RuntimeException", [])]
369comparableType :: ClassType
370comparableType = ClassType [(Ident "Comparable", [])]
372mkDecl :: (Name, SDecl) ->
373 Either String Decl
374mkDecl ((NS n (ns:nss)), decl) =
375 (\ name body -> MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
376 <$> mkIdentifier (UN ns)
377 <*> mkClassBody [(NS n nss, decl)]
378mkDecl (_, SFun name params stackSize body) =
379 (\ name params cont ->
380 MemberDecl $ MethodDecl [Public, Static]
381 []
382 (Just . RefType $ ClassRefType objectType)
383 name
384 params
385 []
386 (MethodBody . Just $ Block [ BlockStmt . Return . Just . MethodInv $
387 PrimaryMethodCall cont [] (Ident "call") []])
388 )
389 <$> mkIdentifier name
390 <*> mapM mkFormalParam params
391 <*> mkClosure params stackSize body
394mkClosure :: [Name] -> Int -> SExp -> Either String Exp
395mkClosure params stackSize body =
396 (\ paramArray body ->
397 InstanceCreation []
398 idrisClosureType
399 [paramArray]
400 (Just $ ClassBody [body])
401 )
402 <$> mkStackInit params stackSize
403 <*> mkClosureCall body
405mkFormalParam :: Name -> Either String FormalParam
406mkFormalParam name =
407 (\ name -> FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId name))
408 <$> mkIdentifier name
410mkClosureCall :: SExp -> Either String Decl
411mkClosureCall body =
412 (\ body -> MemberDecl $ MethodDecl [Public] [] (Just . RefType $ ClassRefType objectType) (Ident "call") [] [] body)
413 <$> mkMethodBody body
415mkMethodBody :: SExp -> Either String MethodBody
416mkMethodBody exp =
417 (\ exp -> MethodBody . Just . Block $ [BlockStmt . Return . Just $ exp])
418 <$> mkExp exp
420mkStackInit :: [Name] -> Int -> Either String Exp
421mkStackInit params stackSize =
422 (\ localVars -> ArrayCreateInit objectArrayType 0 . ArrayInit $
423 (map (InitExp . ExpName) localVars)
424 ++ (replicate (stackSize) (InitExp $ Lit Null)))
425 <$> mapM mkName params
427mkAnonymousLetBinding :: LVar -> SExp -> SExp -> Either String Exp
428mkAnonymousLetBinding var oldExp newExp =
429 (\ bindingMethod newExp ->
430 MethodInv $ PrimaryMethodCall
431 ( MethodInv $ PrimaryMethodCall ( InstanceCreation []
432 objectType
433 []
434 (Just $ ClassBody [MemberDecl $ bindingMethod])
435 )
436 []
437 (Ident "apply")
438 [ contextArray
439 , newExp]
440 )
441 []
442 (Ident "call")
443 []
444 )
445 <$> mkLetBindingMethod var oldExp
446 <*> mkExp newExp
449mkContextParam :: FormalParam
450mkContextParam =
451 FormalParam [Final] (objectArrayType) False (VarId (Ident "context"))
453mkLetBindingMethod :: LVar -> SExp -> Either String MemberDecl
454mkLetBindingMethod (Loc i) oldExp =
455 (\ param bindingStack oldCont ->
456 MethodDecl [Final, Public]
457 []
458 (Just . RefType $ ClassRefType idrisClosureType)
459 (Ident "apply")
460 [mkContextParam, param]
461 []
462 (MethodBody . Just . Block $
463 bindingStack ++ [BlockStmt . Return $ Just oldCont]
464 )
465 )
466 <$> mkFormalParam (UN "param")
467 <*> mkBindingStack True i [UN "param"]
468 <*> mkBindingClosure oldExp
470mkBindingClosure :: SExp -> Either String Exp
471mkBindingClosure oldExp =
472 (\ oldCall ->
473 InstanceCreation []
474 idrisClosureType
475 [ ExpName $ J.Name [Ident "new_context"] ]
476 (Just $ ClassBody [oldCall])
477 )
478 <$> mkClosureCall oldExp
481mkBindingStack :: Bool -> Int -> [Name] -> Either String [BlockStmt]
482mkBindingStack checked parentStackStart params =
483 (\ paramNames ->
484 ( LocalVars [Final]
485 objectArrayType
486 [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
487 (Just . InitExp $ mkContextCopy checked parentStackStart params)
488 ])
489 : ( map (\ (param, pos) ->
490 BlockStmt . ExpStmt $
491 Assign (ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "new_context"])
492 (Lit $ Int (toInteger pos)))
493 EqualA
494 (ExpName param)) $ zip paramNames [parentStackStart..]
495 )
496 )
497 <$> mapM mkName params
499mkContextCopy :: Bool -> Int -> [Name] -> Exp
500mkContextCopy True parentStackStart params =
501 MethodInv $ PrimaryMethodCall (ExpName $ J.Name [Ident "context"])
502 []
503 (Ident "clone")
504 []
505mkContextCopy False parentStackStart params =
506 MethodInv $ TypeMethodCall (J.Name [Ident "Arrays"])
507 []
508 (Ident "copyOf")
509 [ ExpName $ J.Name [Ident "context"]
510 , MethodInv
511 $ TypeMethodCall (J.Name [Ident "Math"])
512 []
513 (Ident "max")
514 [ FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "context"])
515 (Ident "length")
516 , Lit . Int $ toInteger (parentStackStart + length params)
517 ]
518 ]
520reverseNameSpace :: J.Name -> J.Name
521reverseNameSpace (J.Name ids) =
522 J.Name ((tail ids) ++ [head ids])
524mkCase :: Bool -> LVar -> [SAlt] -> Either String Exp
525mkCase checked var ((SConCase parentStackPos consIndex _ params branchExpression):cases) =
526 mkConsCase checked
527 var
528 parentStackPos
529 consIndex
530 params
531 branchExpression
532 (SCase var cases)
533mkCase checked var (c@(SConstCase constant branchExpression):cases) =
534 (\ constant branchExpression alternative ->
535 Cond ( MethodInv $ PrimaryMethodCall (constant)
536 []
537 (Ident "equals")
538 [mkVarAccess Nothing var]
539 )
540 branchExpression
541 alternative
542 )
543 <$> mkExp (SConst constant)
544 <*> mkExp branchExpression
545 <*> mkCase checked var cases
546mkCase checked var (SDefaultCase exp:cases) = mkExp exp
547mkCase checked _ [] = mkExp (SError "Non-exhaustive pattern")
549mkConsCase :: Bool -> LVar -> Int -> Int -> [Name] -> SExp -> SExp -> Either String Exp
550mkConsCase checked
551 toDeconstruct
552 parentStackStart
553 consIndex
554 params
555 branchExpression
556 alternative =
557 (\ caseBinding alternative->
558 Cond (BinOp (InstanceOf (mkVarAccess Nothing toDeconstruct)
559 (ClassRefType idrisObjectType)
560 )
561 CAnd
562 ( BinOp
563 ( MethodInv $ PrimaryMethodCall (mkVarAccess (Just idrisObjectType) toDeconstruct)
564 []
565 (Ident "getConstructorId")
566 []
567 )
568 Equal
569 (Lit $ Int (toInteger consIndex))
570 )
571 )
572 (caseBinding)
573 alternative
574 )
575 <$> mkCaseBinding checked toDeconstruct parentStackStart params branchExpression
576 <*> mkExp alternative
579mkCaseBinding :: Bool -> LVar -> Int -> [Name] -> SExp -> Either String Exp
580mkCaseBinding checked var parentStackStart params branchExpression =
581 (\ bindingMethod ->
582 MethodInv $ PrimaryMethodCall
583 ( MethodInv $ PrimaryMethodCall (InstanceCreation []
584 (ClassType [(Ident "Object", [])])
585 []
586 (Just $ ClassBody [MemberDecl $ bindingMethod])
587 )
588 []
589 (Ident "apply")
590 ( contextArray
591 : (mkCaseBindingDeconstruction var params)
592 )
593 )
594 []
595 (Ident "call")
596 []
597 )
598 <$> mkCaseBindingMethod checked parentStackStart params branchExpression
602mkCaseBindingMethod :: Bool -> Int -> [Name] -> SExp -> Either String MemberDecl
603mkCaseBindingMethod checked parentStackStart params branchExpression =
604 (\ formalParams caseBindingStack branchExpression ->
605 MethodDecl [Final, Public]
606 []
607 (Just . RefType $ ClassRefType idrisClosureType)
608 (Ident "apply")
609 (mkContextParam:formalParams)
610 []
611 (MethodBody . Just . Block $
612 caseBindingStack ++
613 [BlockStmt . Return $ Just branchExpression]))
614 <$> mapM mkFormalParam params
615 <*> mkBindingStack checked parentStackStart params
616 <*> mkBindingClosure branchExpression
618mkCaseBindingDeconstruction :: LVar -> [Name] -> [Exp]
619mkCaseBindingDeconstruction var members =
620 map (mkProjection var) ([0..(length members - 1)])
622mkProjection :: LVar -> Int -> Exp
623mkProjection var memberNr =
624 ArrayAccess $ ArrayIndex ( MethodInv $ PrimaryMethodCall
625 (mkVarAccess (Just idrisObjectType) var)
626 []
627 (Ident "getData")
628 []
629 )
630 (Lit $ Int (toInteger memberNr))
632type ClassName = String
634mkPrimitive :: ClassName -> Literal -> Exp
635mkPrimitive className value =
636 MethodInv $ TypeMethodCall (J.Name [Ident className])
637 []
638 (Ident "valueOf")
639 [Lit $ value]
641mkClass :: ClassType -> Exp
642mkClass classType =
643 ClassLit . Just . RefType .ClassRefType $ classType
645mkBinOpExp :: ClassType -> Op -> [LVar] -> Exp
646mkBinOpExp castTo op (var:vars) =
647 foldl (\ exp -> BinOp exp op . mkVarAccess (Just castTo))
648 (mkVarAccess (Just castTo) var)
649 vars
651mkBinOpExpTrans :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> Op -> [LVar] -> Exp
652mkBinOpExpTrans opTransformation resultTransformation castTo op (var:vars) =
653 foldl (\ exp -> resultTransformation
654 . BinOp (opTransformation exp) op
655 . opTransformation
656 . mkVarAccess (Just castTo))
657 (mkVarAccess (Just castTo) var)
658 vars
660mkBinOpExpConv :: String -> PrimType -> ClassType -> Op -> [LVar] -> Exp
661mkBinOpExpConv fromMethodName toType fromType@(ClassType [(cls@(Ident _), [])]) op args =
662 mkBinOpExpTrans (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
663 []
664 (Ident fromMethodName)
665 [exp]
666 )
667 (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
668 []
669 (Ident "valueOf")
670 [Cast (PrimType $ toType) exp]
671 )
672 fromType
673 op
674 args
676mkLogicalBinOpExp :: ClassType -> Op -> [LVar] -> Exp
677mkLogicalBinOpExp castTo op (var:vars) =
678 foldl (\ exp -> mkBoolToNumber castTo . BinOp exp op . mkVarAccess (Just castTo))
679 (mkVarAccess (Just castTo) var)
680 vars
682mkMethodOpChain1 :: (Exp -> Exp) -> ClassType -> String -> [LVar] -> Exp
683mkMethodOpChain1 = mkMethodOpChain id
685mkMethodOpChain :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> String -> [LVar] -> Exp
686mkMethodOpChain initialTransformation resultTransformation castTo method (arg:args) =
687 foldl (\ exp arg' ->
688 resultTransformation . MethodInv $ PrimaryMethodCall exp
689 []
690 (Ident method)
691 [mkVarAccess (Just $ castTo) arg']
692 )
693 (initialTransformation (mkVarAccess (Just $ castTo) arg))
694 args
696mkBoolToNumber :: ClassType -> Exp -> Exp
697mkBoolToNumber (ClassType [(Ident name, [])]) boolExp =
698 Cond boolExp (mkPrimitive name (Int 1)) (mkPrimitive name (Int 0))
700mkZeroExt :: String -> Int -> ClassType -> ClassType -> LVar -> Exp
701mkZeroExt toMethod bits fromType toType@(ClassType [(toTypeName, [])]) var =
702 MethodInv $ TypeMethodCall (J.Name [toTypeName])
703 []
704 (Ident "valueOf")
705 [ Cond ( BinOp (mkVarAccess (Just $ fromType) var)
706 LThan
707 (Lit $ Int 0)
708 )
709 ( BinOp (Lit $ Int (2^bits))
710 Add
711 (mkSignedExt' toMethod fromType var)
712 )
713 (mkSignedExt' toMethod fromType var)
714 ]
716mkSignedExt :: String -> ClassType -> ClassType -> LVar -> Exp
717mkSignedExt toMethod fromType (ClassType [(toTypeName, [])]) var =
718 MethodInv $ TypeMethodCall (J.Name [toTypeName])
719 []
720 (Ident "valueOf")
721 [ mkSignedExt' toMethod fromType var ]
723mkSignedExt' :: String -> ClassType -> LVar -> Exp
724mkSignedExt' toMethod fromType var =
725 MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ fromType) var)
726 []
727 (Ident toMethod)
728 []
730data SPartialOrder
731 = SLt
732 | SLe
733 | SEq
734 | SGe
735 | SGt
737mkPartialOrder :: SPartialOrder -> Exp -> Exp
738mkPartialOrder SLt x = (BinOp (Lit $ Int (-1)) Equal x)
739mkPartialOrder SLe x =
740 BinOp (BinOp (Lit $ Int (-1)) Equal x)
741 COr
742 (BinOp (Lit $ Int 0) Equal x)
743mkPartialOrder SEq x = BinOp (Lit $ Int 0) Equal x
744mkPartialOrder SGe x =
745 BinOp (BinOp (Lit $ Int 1) Equal x)
746 COr
747 (BinOp (Lit $ Int 0) Equal x)
748mkPartialOrder SGt x = (BinOp (Lit $ Int 1) Equal x)
750mkVarAccess :: Maybe ClassType -> LVar -> Exp
751mkVarAccess Nothing (Loc i) =
752 ArrayAccess $ ArrayIndex contextArray (Lit $ Int (toInteger i))
753mkVarAccess (Just castTo) var =
754 Cast (RefType . ClassRefType $ castTo) (mkVarAccess Nothing var)
756mkPrimitiveCast :: ClassType -> ClassType -> LVar -> Exp
757mkPrimitiveCast fromType (ClassType [(toType, [])]) var =
758 MethodInv $ TypeMethodCall (J.Name [toType])
759 []
760 (Ident "valueOf")
761 [mkVarAccess (Just fromType) var]
763mkToString :: ClassType -> LVar -> Exp
764mkToString castTo var =
765 MethodInv $ PrimaryMethodCall (mkVarAccess (Just castTo) var)
766 []
767 (Ident "toString")
768 []
770data Std = In | Out | Err
772instance Show Std where
773 show In = "in"
774 show Out = "out"
775 show Err = "err"
777mkSystemStd :: Std -> Exp
778mkSystemStd std = FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "System"]) (Ident $ show std)
780mkSystemOutPrint :: Exp -> Exp
781mkSystemOutPrint value =
782 MethodInv $ PrimaryMethodCall (mkSystemStd Out)
783 []
784 (Ident "print")
785 [value]
787mkMathFun :: String -> LVar -> Exp
788mkMathFun funName var =
789 MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
790 []
791 (Ident "valueOf")
792 [ MethodInv $ TypeMethodCall (J.Name [Ident "Math"])
793 []
794 (Ident funName)
795 [mkVarAccess (Just doubleType) var]
796 ]
798mkStringAtIndex :: LVar -> Exp -> Exp
799mkStringAtIndex var indexExp =
800 MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])
801 []
802 (Ident "valueOf")
803 [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just stringType) var)
804 []
805 (Ident "charAt")
806 [indexExp]
807 ]
809mkForeignType :: FType -> Maybe ClassType
810mkForeignType FInt = return $ integerType
811mkForeignType FChar = return $ integerType
812mkForeignType FString = return $ stringType
813mkForeignType FPtr = return $ objectType
814mkForeignType FDouble = return $ doubleType
815mkForeignType FAny = return $ objectType
816mkForeignType FUnit = Nothing
818mkForeignVarAccess :: FType -> LVar -> Exp
819mkForeignVarAccess FInt var =
820 MethodInv $ PrimaryMethodCall (mkVarAccess (Just integerType) var)
821 []
822 (Ident "intValue")
823 []
824mkForeignVarAccess FChar var = Cast (PrimType CharT) (mkForeignVarAccess FInt var)
825mkForeignVarAccess FDouble var =
826 MethodInv $ PrimaryMethodCall (mkVarAccess (Just doubleType) var)
827 []
828 (Ident "doubleValue")
829 []
830mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var
832mkFromForeignType :: FType -> Exp -> Exp
833mkFromForeignType FInt from =
834 MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])
835 []
836 (Ident "valueOf")
837 [from]
838mkFromForeignType FChar from = mkFromForeignType FInt from
839mkFromForeignType FDouble from =
840 MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
841 []
842 (Ident "valueOf")
843 [from]
844mkFromForeignType _ from = from
846mkForeignInvoke :: FType -> String -> [(FType, LVar)] -> Either String Exp
847mkForeignInvoke fType method args =
848 (\ foreignInvokeMeth ->
849 MethodInv $ PrimaryMethodCall (InstanceCreation []
850 objectType
851 []
852 (Just $ ClassBody [ MemberDecl $ foreignInvokeMeth ])
853 )
854 []
855 (Ident "foreignInvoke")
856 []
857 )
858 <$> mkForeignInvokeMethod fType method args
861mkForeignInvokeMethod :: FType -> String -> [(FType, LVar)] -> Either String MemberDecl
862mkForeignInvokeMethod fType method args =
863 (\ tryBlock ->
864 MethodDecl [Public, Final]
865 []
866 (Just . RefType $ ClassRefType objectType)
867 (Ident "foreignInvoke")
868 []
869 []
870 (MethodBody . Just $ Block [ BlockStmt $
871 Try tryBlock
872 [ Catch (FormalParam []
873 (RefType $ ClassRefType exceptionType)
874 False
875 (VarId $ Ident "ex")
876 )
877 (Block [ BlockStmt . Throw $
878 InstanceCreation []
879 runtimeExceptionType
880 [ExpName $ J.Name [Ident "ex"]]
881 Nothing
882 ]
883 )
884 ]
885 Nothing
886 ]
887 )
888 )
889 <$> mkForeignInvokeTryBlock fType method args
892mkForeignInvokeTryBlock :: FType -> String -> [(FType, LVar)] -> Either String Block
893mkForeignInvokeTryBlock FUnit method args =
894 (\ method -> Block [ BlockStmt . ExpStmt . MethodInv $
895 MethodCall method
896 (map (uncurry mkForeignVarAccess) args)
897 , BlockStmt $ Return (Just $ Lit Null)
898 ]
899 )
900 <$> ( left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
901 (parser name method)
902 )
903mkForeignInvokeTryBlock fType method args =
904 (\ method -> Block [ BlockStmt . Return
905 . Just
906 . mkFromForeignType fType
907 . MethodInv $
908 MethodCall method
909 (map (uncurry mkForeignVarAccess) args)
910 ]
911 )
912 <$> ( left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
913 (parser name method)
914 )
916mkMethodClosure :: Name -> [LVar] -> Either String Exp
917mkMethodClosure name args =
918 (\ name args ->
919 InstanceCreation []
920 idrisClosureType
921 [ (ExpName $ J.Name [Ident "context"]) ]
922 ( Just $ ClassBody
923 [ MemberDecl $
924 MethodDecl [Public, Final]
925 []
926 (Just . RefType $ ClassRefType objectType)
927 (Ident "call")
928 []
929 []
930 ( MethodBody . Just $
931 Block [ BlockStmt . Return . Just . MethodInv $
932 MethodCall (reverseNameSpace name)
933 args
934 ]
935 )
936 ]
937 )
938 )
939 <$> mkName name
940 <*> mapM (mkExp . SV) args
942mkThread :: LVar -> Either String Exp
943mkThread arg =
944 (\ eval -> MethodInv $
945 PrimaryMethodCall (InstanceCreation []
946 (ClassType [(Ident "Thread", [])])
947 [ eval ]
948 ( Just $ ClassBody
949 [ MemberDecl $ MethodDecl
950 [Public, Final]
951 []
952 (Just . RefType $ ClassRefType objectType)
953 (Ident "_start")
954 []
955 []
956 ( MethodBody . Just $ Block
957 [ BlockStmt . ExpStmt . MethodInv $ MethodCall
958 (J.Name [Ident "start"])
959 []
960 , BlockStmt . Return . Just $ This
961 ]
962 )
963 ]
964 )
965 )
966 []
967 (Ident "_start")
968 []
969 )
970 <$> mkThreadBinding arg
972mkThreadBinding :: LVar -> Either String Exp
973mkThreadBinding var =
974 (\ bindingMethod ->
975 MethodInv $ PrimaryMethodCall ( InstanceCreation []
976 objectType
977 []
978 (Just $ ClassBody [MemberDecl $ bindingMethod])
979 )
980 []
981 (Ident "apply")
982 [ mkVarAccess Nothing var ]
983 )
984 <$> mkThreadBindingMethod
987mkThreadBindingMethod :: Either String MemberDecl
988mkThreadBindingMethod =
989 (\ compute ->
990 MethodDecl [Final, Public]
991 []
992 (Just . RefType $ ClassRefType idrisClosureType)
993 (Ident "apply")
994 [ FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId $ Ident "param") ]
995 []
996 (MethodBody . Just $ Block
997 [ mkThreadBindingStack
998 , BlockStmt . Return $ Just compute
999 ]
1002 <$> mkBindingClosure (SUpdate (Loc 0) (SApp False (MN 0 "EVAL") [Loc 0]))
1005mkThreadBindingStack :: BlockStmt
1006mkThreadBindingStack =
1007 LocalVars [Final]
1008 objectArrayType
1009 [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
1010 (Just . InitArray $ ArrayInit [InitExp . ExpName $ J.Name [Ident "param"]])
1014mkExp :: SExp -> Either String Exp
1015mkExp (SV var) =
1016 return $ mkVarAccess Nothing var
1017mkExp (SApp False name args) =
1018 (\ methClosure ->
1019 MethodInv $ PrimaryMethodCall ( InstanceCreation []
1020 idrisTailCallClosureType
1021 [ methClosure ]
1022 Nothing
1024 []
1025 (Ident "call")
1026 []
1028 <$> mkMethodClosure name args
1029mkExp (SApp True name args) =
1030 (\ methClosure ->
1031 ( InstanceCreation []
1032 idrisTailCallClosureType
1033 [ methClosure ]
1034 Nothing
1037 <$> mkMethodClosure name args
1038mkExp (SLet var new old) =
1039 mkAnonymousLetBinding var old new
1040mkExp (SUpdate (Loc i) exp) =
1041 (\ rhs -> Assign (ArrayLhs $ ArrayIndex (contextArray) (Lit $ Int (toInteger i)))
1042 EqualA
1043 rhs)
1044 <$> mkExp exp
1045mkExp (SCon conId name args) =
1046 (\ args -> InstanceCreation []
1047 idrisObjectType
1048 ((Lit $ Int (toInteger conId)):args)
1049 Nothing)
1050 <$> mapM (mkExp .SV) args
1051mkExp (SCase var alts) = mkCase False var alts
1052mkExp (SChkCase var alts) = mkCase True var alts
1053mkExp (SProj var i) = return $ mkProjection var i
1054mkExp (SConst (I x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
1055mkExp (SConst (BI x)) =
1056 return $ InstanceCreation []
1057 (ClassType [(Ident "BigInteger", [])])
1058 [Lit $ String (show x)]
1059 Nothing
1060mkExp (SConst (Fl x)) = return $ mkPrimitive "Double" (Double x)
1061mkExp (SConst (Ch x)) = return $ mkPrimitive "Integer" (Char x)
1062mkExp (SConst (Str x)) = return $ Lit $ String x
1063mkExp (SConst IType) = return $ mkClass integerType
1064mkExp (SConst BIType) = return $ mkClass bigIntegerType
1065mkExp (SConst FlType) = return $ mkClass doubleType
1066mkExp (SConst ChType) = return $ mkClass charType
1067mkExp (SConst StrType) = return $ mkClass stringType
1068mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (Int (toInteger x))
1069mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (Int (toInteger x))
1070mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
1071mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (Int (toInteger x))
1072mkExp (SConst (B8Type))= return $ mkClass byteType
1073mkExp (SConst (B16Type)) = return $ mkClass shortType
1074mkExp (SConst (B32Type)) = return $ mkClass integerType
1075mkExp (SConst (B64Type)) = return $ mkClass longType
1076mkExp (SConst (PtrType)) = return $ mkClass objectType
1077mkExp (SConst (VoidType)) = return $ mkClass voidType
1078mkExp (SConst (Forgot)) = return $ mkClass objectType
1079mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args
1080mkExp (SOp LPlus args) = return $ mkBinOpExp integerType Add args
1081mkExp (SOp LMinus args) = return $ mkBinOpExp integerType Sub args
1082mkExp (SOp LTimes args) = return $ mkBinOpExp integerType Mult args
1083mkExp (SOp LDiv args) = return $ mkBinOpExp integerType Div args
1084mkExp (SOp LMod args) = return $ mkBinOpExp integerType Rem args
1085mkExp (SOp LAnd args) = return $ mkBinOpExp integerType And args
1086mkExp (SOp LOr args) = return $ mkBinOpExp integerType Or args
1087mkExp (SOp LXOr args) = return $ mkBinOpExp integerType Xor args
1088mkExp (SOp LCompl [var]) =
1089 return $ PreBitCompl (mkVarAccess (Just $ integerType) var)
1090mkExp (SOp LSHL args) = return $ mkBinOpExp integerType LShift args
1091mkExp (SOp LSHR args) = return $ mkBinOpExp integerType RShift args
1092mkExp (SOp LEq args) =
1093 return $ mkMethodOpChain1 (mkBoolToNumber integerType) objectType "equals" args
1094mkExp (SOp LLt args) = return $ mkLogicalBinOpExp integerType LThan args
1095mkExp (SOp LLe args) = return $ mkLogicalBinOpExp integerType LThanE args
1096mkExp (SOp LGt args) = return $ mkLogicalBinOpExp integerType GThan args
1097mkExp (SOp LGe args) = return $ mkLogicalBinOpExp integerType GThanE args
1098mkExp (SOp LFPlus args) = return $ mkBinOpExp doubleType Add args
1099mkExp (SOp LFMinus args) = return $ mkBinOpExp doubleType Sub args
1100mkExp (SOp LFTimes args) = return $ mkBinOpExp doubleType Mult args
1101mkExp (SOp LFDiv args) = return $ mkBinOpExp doubleType Div args
1102mkExp (SOp LFEq args) =
1103 return $ mkMethodOpChain1 (mkBoolToNumber doubleType) doubleType "equals" args
1104mkExp (SOp LFLt args) = return $ mkLogicalBinOpExp integerType LThan args
1105mkExp (SOp LFLe args) = return $ mkLogicalBinOpExp integerType LThanE args
1106mkExp (SOp LFGt args) = return $ mkLogicalBinOpExp integerType GThan args
1107mkExp (SOp LFGe args) = return $ mkLogicalBinOpExp integerType GThanE args
1108mkExp (SOp LBPlus args) = return $ mkMethodOpChain1 id bigIntegerType "add" args
1109mkExp (SOp LBMinus args) = return $ mkMethodOpChain1 id bigIntegerType "subtract" args
1110mkExp (SOp LBTimes args) = return $ mkMethodOpChain1 id bigIntegerType "multiply" args
1111mkExp (SOp LBDiv args) = return $ mkMethodOpChain1 id bigIntegerType "divide" args
1112mkExp (SOp LBMod args) = return $ mkMethodOpChain1 id bigIntegerType "mod" args
1113mkExp (SOp LBEq args) =
1114 return $ mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args
1115mkExp (SOp LBLt args) =
1116 return $ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1117 . mkPartialOrder SLt
1118 )
1119 bigIntegerType
1120 "compare"
1121 args
1122mkExp (SOp LBLe args) =
1123 return $ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1124 . mkPartialOrder SLe
1125 )
1126 bigIntegerType
1127 "compare"
1128 args
1129mkExp (SOp LBGt args) =
1130 return $ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1131 . mkPartialOrder SGt
1132 )
1133 bigIntegerType
1134 "compare"
1135 args
1136mkExp (SOp LBGe args) =
1137 return $ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1138 . mkPartialOrder SGe
1139 )
1140 bigIntegerType
1141 "compare"
1142 args
1143mkExp (SOp LStrConcat args) =
1144 return $ mkMethodOpChain (\ exp ->
1145 InstanceCreation []
1146 (ClassType [(Ident "StringBuilder", [])])
1147 [exp]
1148 Nothing
1150 (\ exp -> MethodInv $ PrimaryMethodCall exp [] (Ident "toString") [])
1151 stringType
1152 "append"
1153 args
1154mkExp (SOp LStrLt args@[_, _]) =
1155 return $ mkMethodOpChain1 ( mkBoolToNumber integerType
1156 . mkPartialOrder SLt
1158 stringType
1159 "compare"
1160 args
1161mkExp (SOp LStrEq args@[_, _]) =
1162 return $ mkMethodOpChain1 ( mkBoolToNumber integerType)
1163 stringType
1164 "equals"
1165 args
1166mkExp (SOp LStrLen [arg]) =
1167 return . MethodInv $ PrimaryMethodCall (mkVarAccess (Just stringType) arg) [] (Ident "length") []
1168mkExp (SOp LIntFloat [arg]) =
1169 return $ mkPrimitiveCast integerType doubleType arg
1170mkExp (SOp LFloatInt [arg]) =
1171 return $ mkPrimitiveCast doubleType integerType arg
1172mkExp (SOp LIntStr [arg]) =
1173 return $ mkToString integerType arg
1174mkExp (SOp LStrInt [arg]) =
1175 return $ mkPrimitiveCast stringType integerType arg
1176mkExp (SOp LFloatStr [arg]) =
1177 return $ mkToString doubleType arg
1178mkExp (SOp LStrFloat [arg]) =
1179 return $ mkPrimitiveCast doubleType stringType arg
1180mkExp (SOp LIntBig [arg]) =
1181 return $ mkPrimitiveCast integerType bigIntegerType arg
1182mkExp (SOp LBigInt [arg]) =
1183 return $ mkPrimitiveCast bigIntegerType integerType arg
1184mkExp (SOp LStrBig [arg]) =
1185 return $ InstanceCreation [] bigIntegerType [mkVarAccess (Just stringType) arg] Nothing
1186mkExp (SOp LBigStr [arg]) =
1187 return $ mkToString bigIntegerType arg
1188mkExp (SOp LChInt [arg]) =
1189 return $ mkVarAccess (Just integerType) arg
1190mkExp (SOp LIntCh [arg]) =
1191 return $ mkVarAccess (Just integerType) arg
1192mkExp (SOp LPrintNum [arg]) =
1193 return $ mkSystemOutPrint (mkVarAccess Nothing arg)
1194mkExp (SOp LPrintStr [arg]) =
1195 return $ mkSystemOutPrint (mkVarAccess (Just stringType) arg)
1196mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)])
1197mkExp (SOp LB8Lt args) = return $ mkLogicalBinOpExp byteType LThan args
1198mkExp (SOp LB8Lte args) = return $ mkLogicalBinOpExp byteType LThanE args
1199mkExp (SOp LB8Eq args) =
1200 return $ mkMethodOpChain1 (mkBoolToNumber byteType) byteType "equals" args
1201mkExp (SOp LB8Gt args) = return $ mkLogicalBinOpExp byteType GThan args
1202mkExp (SOp LB8Gte args) = return $ mkLogicalBinOpExp byteType GThanE args
1203mkExp (SOp LB8Plus args) = return $ mkBinOpExp byteType Add args
1204mkExp (SOp LB8Minus args) = return $ mkBinOpExp byteType Sub args
1205mkExp (SOp LB8Times args) = return $ mkBinOpExp byteType Mult args
1206mkExp (SOp LB8UDiv args) = return $ mkBinOpExpConv "shortValue" ShortT byteType Div args
1207mkExp (SOp LB8SDiv args) = return $ mkBinOpExp byteType Div args
1208mkExp (SOp LB8URem args) = return $ mkBinOpExpConv "shortValue" ShortT byteType Rem args
1209mkExp (SOp LB8SRem args) = return $ mkBinOpExp byteType Rem args
1210mkExp (SOp LB8Shl args) = return $ mkBinOpExp byteType LShift args
1211mkExp (SOp LB8LShr args) = return $ mkBinOpExp byteType RRShift args
1212mkExp (SOp LB8AShr args) = return $ mkBinOpExp byteType RShift args
1213mkExp (SOp LB8And args) = return $ mkBinOpExp byteType And args
1214mkExp (SOp LB8Or args) = return $ mkBinOpExp byteType Or args
1215mkExp (SOp LB8Xor args) = return $ mkBinOpExp byteType Xor args
1216mkExp (SOp LB8Compl [var]) =
1217 return $ PreBitCompl (mkVarAccess (Just $ byteType) var)
1218mkExp (SOp LB8Z16 [var]) = return $ mkZeroExt "shortValue" 8 byteType shortType var
1219mkExp (SOp LB8Z32 [var]) = return $ mkZeroExt "intValue" 8 byteType integerType var
1220mkExp (SOp LB8Z64 [var]) = return $ mkZeroExt "longValue" 8 byteType longType var
1221mkExp (SOp LB8S16 [var]) = return $ mkSignedExt "shortValue" byteType shortType var
1222mkExp (SOp LB8S32 [var]) = return $ mkSignedExt "intValue" byteType integerType var
1223mkExp (SOp LB8S64 [var]) = return $ mkSignedExt "longValue" byteType longType var
1224mkExp (SOp LB16Lt args) = return $ mkLogicalBinOpExp shortType LThan args
1225mkExp (SOp LB16Lte args) = return $ mkLogicalBinOpExp shortType LThanE args
1226mkExp (SOp LB16Eq args) =
1227 return $ mkMethodOpChain1 (mkBoolToNumber shortType) shortType "equals" args
1228mkExp (SOp LB16Gt args) = return $ mkLogicalBinOpExp shortType GThan args
1229mkExp (SOp LB16Gte args) = return $ mkLogicalBinOpExp shortType GThanE args
1230mkExp (SOp LB16Plus args) = return $ mkBinOpExp shortType Add args
1231mkExp (SOp LB16Minus args) = return $ mkBinOpExp shortType Sub args
1232mkExp (SOp LB16Times args) = return $ mkBinOpExp shortType Mult args
1233mkExp (SOp LB16UDiv args) = return $ mkBinOpExpConv "intValue" IntT shortType Div args
1234mkExp (SOp LB16SDiv args) = return $ mkBinOpExp shortType Div args
1235mkExp (SOp LB16URem args) = return $ mkBinOpExpConv "intValue" IntT shortType Rem args
1236mkExp (SOp LB16SRem args) = return $ mkBinOpExp shortType Rem args
1237mkExp (SOp LB16Shl args) = return $ mkBinOpExp shortType LShift args
1238mkExp (SOp LB16LShr args) = return $ mkBinOpExp shortType RRShift args
1239mkExp (SOp LB16AShr args) = return $ mkBinOpExp shortType RShift args
1240mkExp (SOp LB16And args) = return $ mkBinOpExp shortType And args
1241mkExp (SOp LB16Or args) = return $ mkBinOpExp shortType Or args
1242mkExp (SOp LB16Xor args) = return $ mkBinOpExp shortType Xor args
1243mkExp (SOp LB16Compl [var]) =
1244 return $ PreBitCompl (mkVarAccess (Just $ shortType) var)
1245mkExp (SOp LB16Z32 [var]) = return $ mkZeroExt "intValue" 16 shortType integerType var
1246mkExp (SOp LB16Z64 [var]) = return $ mkZeroExt "longValue" 16 shortType longType var
1247mkExp (SOp LB16S32 [var]) = return $ mkSignedExt "intValue" shortType integerType var
1248mkExp (SOp LB16S64 [var]) = return $ mkSignedExt "longValue" shortType longType var
1249mkExp (SOp LB16T8 [var]) =
1250 return . MethodInv $
1251 TypeMethodCall (J.Name [Ident "Byte"])
1252 []
1253 (Ident "valueOf")
1254 [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ shortType) var) [] (Ident "byteValue") [] ]
1255mkExp (SOp LB32Lt args) = return $ mkLogicalBinOpExp integerType LThan args
1256mkExp (SOp LB32Lte args) = return $ mkLogicalBinOpExp integerType LThanE args
1257mkExp (SOp LB32Eq args) =
1258 return $ mkMethodOpChain1 (mkBoolToNumber integerType) integerType "equals" args
1259mkExp (SOp LB32Gt args) = return $ mkLogicalBinOpExp integerType GThan args
1260mkExp (SOp LB32Gte args) = return $ mkLogicalBinOpExp integerType GThanE args
1261mkExp (SOp LB32Plus args) = return $ mkBinOpExp integerType Add args
1262mkExp (SOp LB32Minus args) = return $ mkBinOpExp integerType Sub args
1263mkExp (SOp LB32Times args) = return $ mkBinOpExp integerType Mult args
1264mkExp (SOp LB32UDiv args) = return $ mkBinOpExpConv "longValue" LongT integerType Div args
1265mkExp (SOp LB32SDiv args) = return $ mkBinOpExp integerType Div args
1266mkExp (SOp LB32URem args) = return $ mkBinOpExpConv "longValue" LongT integerType Rem args
1267mkExp (SOp LB32SRem args) = return $ mkBinOpExp integerType Rem args
1268mkExp (SOp LB32Shl args) = return $ mkBinOpExp integerType LShift args
1269mkExp (SOp LB32LShr args) = return $ mkBinOpExp integerType RRShift args
1270mkExp (SOp LB32AShr args) = return $ mkBinOpExp integerType RShift args
1271mkExp (SOp LB32And args) = return $ mkBinOpExp integerType And args
1272mkExp (SOp LB32Or args) = return $ mkBinOpExp integerType Or args
1273mkExp (SOp LB32Xor args) = return $ mkBinOpExp integerType Xor args
1274mkExp (SOp LB32Compl [var]) =
1275 return $ PreBitCompl (mkVarAccess (Just $ integerType) var)
1276mkExp (SOp LB32Z64 [var]) = return $ mkZeroExt "longValue" 32 integerType longType var
1277mkExp (SOp LB32S64 [var]) = return $ mkSignedExt "longValue" integerType longType var
1278mkExp (SOp LB32T8 [var]) =
1279 return . MethodInv $
1280 TypeMethodCall (J.Name [Ident "Byte"])
1281 []
1282 (Ident "valueOf")
1283 [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ integerType) var) [] (Ident "byteValue") [] ]
1284mkExp (SOp LB32T16 [var]) =
1285 return . MethodInv $
1286 TypeMethodCall (J.Name [Ident "Short"])
1287 []
1288 (Ident "valueOf")
1289 [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ integerType) var) [] (Ident "shortValue") [] ]
1290mkExp (SOp LB64Lt args) = return $ mkLogicalBinOpExp longType LThan args
1291mkExp (SOp LB64Lte args) = return $ mkLogicalBinOpExp longType LThanE args
1292mkExp (SOp LB64Eq args) =
1293 return $ mkMethodOpChain1 (mkBoolToNumber longType) longType "equals" args
1294mkExp (SOp LB64Gt args) = return $ mkLogicalBinOpExp longType GThan args
1295mkExp (SOp LB64Gte args) = return $ mkLogicalBinOpExp longType GThanE args
1296mkExp (SOp LB64Plus args) = return $ mkBinOpExp longType Add args
1297mkExp (SOp LB64Minus args) = return $ mkBinOpExp longType Sub args
1298mkExp (SOp LB64Times args) = return $ mkBinOpExp longType Mult args
1299mkExp (SOp LB64UDiv (arg:args)) =
1300 return $ foldl (\ exp arg ->
1301 MethodInv $ PrimaryMethodCall
1302 ( MethodInv $ PrimaryMethodCall
1303 ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1304 []
1305 (Ident "valueOf")
1306 [ exp ]
1308 []
1309 (Ident "divide")
1310 [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1311 []
1312 (Ident "valueOf")
1313 [ (mkVarAccess (Just longType) arg) ]
1316 []
1317 (Ident "longValue")
1318 []
1319 )
1320 (mkVarAccess (Just longType) arg)
1321 args
1322mkExp (SOp LB64SDiv args) = return $ mkBinOpExp longType Div args
1323mkExp (SOp LB64URem (arg:args)) =
1324 return $ foldl (\ exp arg ->
1325 MethodInv $ PrimaryMethodCall
1326 ( MethodInv $ PrimaryMethodCall
1327 ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1328 []
1329 (Ident "valueOf")
1330 [ exp ]
1332 []
1333 (Ident "remainder")
1334 [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1335 []
1336 (Ident "valueOf")
1337 [ (mkVarAccess (Just longType) arg) ]
1340 []
1341 (Ident "longValue")
1342 []
1343 )
1344 (mkVarAccess (Just longType) arg)
1345 args
1346mkExp (SOp LB64SRem args) = return $ mkBinOpExp longType Rem args
1347mkExp (SOp LB64Shl args) = return $ mkBinOpExp longType LShift args
1348mkExp (SOp LB64LShr args) = return $ mkBinOpExp longType RRShift args
1349mkExp (SOp LB64AShr args) = return $ mkBinOpExp longType RShift args
1350mkExp (SOp LB64And args) = return $ mkBinOpExp longType And args
1351mkExp (SOp LB64Or args) = return $ mkBinOpExp longType Or args
1352mkExp (SOp LB64Xor args) = return $ mkBinOpExp longType Xor args
1353mkExp (SOp LB64Compl [var]) =
1354 return $ PreBitCompl (mkVarAccess (Just $ longType) var)
1355mkExp (SOp LB64T8 [var]) =
1356 return . MethodInv $
1357 TypeMethodCall (J.Name [Ident "Byte"])
1358 []
1359 (Ident "valueOf")
1360 [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ longType) var) [] (Ident "byteValue") [] ]
1361mkExp (SOp LB64T16 [var]) =
1362 return . MethodInv $
1363 TypeMethodCall (J.Name [Ident "Short"])
1364 []
1365 (Ident "valueOf")
1366 [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ longType) var) [] (Ident "shortValue") [] ]
1367mkExp (SOp LB64T32 [var]) =
1368 return . MethodInv $
1369 TypeMethodCall (J.Name [Ident "Integer"])
1370 []
1371 (Ident "valueOf")
1372 [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ longType) var) [] (Ident "intValue") [] ]
1373mkExp (SOp LIntB8 [arg]) = mkExp (SOp LB32T8 [arg])
1374mkExp (SOp LIntB16 [arg]) = mkExp (SOp LB32T16 [arg])
1375mkExp (SOp LIntB32 [arg]) = mkExp (SV arg)
1376mkExp (SOp LIntB64 [arg]) = mkExp (SOp LB32S64 [arg])
1377mkExp (SOp LB32Int [arg]) = mkExp (SV arg)
1378mkExp (SOp LFExp [arg]) = return $ mkMathFun "exp" arg
1379mkExp (SOp LFLog [arg]) = return $ mkMathFun "log" arg
1380mkExp (SOp LFSin [arg]) = return $ mkMathFun "sin" arg
1381mkExp (SOp LFCos [arg]) = return $ mkMathFun "cos" arg
1382mkExp (SOp LFTan [arg]) = return $ mkMathFun "tan" arg
1383mkExp (SOp LFASin [arg]) = return $ mkMathFun "asin" arg
1384mkExp (SOp LFACos [arg]) = return $ mkMathFun "acos" arg
1385mkExp (SOp LFATan [arg]) = return $ mkMathFun "atan" arg
1386mkExp (SOp LFSqrt [arg]) = return $ mkMathFun "sqrt" arg
1387mkExp (SOp LFFloor [arg]) = return $ mkMathFun "floor" arg
1388mkExp (SOp LFCeil [arg]) = return $ mkMathFun "ceil" arg
1389mkExp (SOp LStrHead [arg]) = return $ mkStringAtIndex arg (Lit $ Int 0)
1390mkExp (SOp LStrTail [arg]) =
1391 return . MethodInv $ PrimaryMethodCall (mkVarAccess (Just stringType) arg)
1392 []
1393 (Ident "substring")
1394 [Lit $ Int 1]
1395mkExp (SOp LStrCons [c, cs]) =
1396 return . MethodInv $
1397 PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
1398 (ClassType [(Ident "StringBuilder", [])])
1399 [mkVarAccess (Just stringType) cs]
1400 Nothing
1402 []
1403 (Ident "insert")
1404 [ Lit $ Int 0,
1405 Cast (PrimType CharT)
1406 (MethodInv $ PrimaryMethodCall
1407 (mkVarAccess (Just integerType) c)
1408 []
1409 (Ident "intValue")
1410 []
1414 []
1415 (Ident "toString")
1416 []
1417mkExp (SOp LStrIndex [str, i]) = return $ mkStringAtIndex str (mkVarAccess (Just integerType) i)
1418mkExp (SOp LStrRev [str]) =
1419 return . MethodInv $
1420 PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
1421 (ClassType [(Ident "StringBuffer", [])])
1422 [mkVarAccess (Just stringType) str]
1423 Nothing
1425 []
1426 (Ident "reverse")
1427 []
1429 []
1430 (Ident "toString")
1431 []
1432mkExp (SOp LStdIn []) = return $ mkSystemStd In
1433mkExp (SOp LStdOut []) = return $ mkSystemStd Out
1434mkExp (SOp LStdErr []) = return $ mkSystemStd Err
1435mkExp (SOp LFork [arg]) = mkThread arg
1436mkExp (SOp LPar [arg]) = mkExp (SV arg)
1437mkExp (SOp LVMPtr []) =
1438 return . MethodInv $ TypeMethodCall (J.Name [Ident "Thread"]) [] (Ident "currentThread") []
1439mkExp (SOp LNoOp args) = mkExp . SV $ last args
1440mkExp (SNothing) = return $ Lit Null
1441mkExp (SError err) =
1442 return . MethodInv $
1443 PrimaryMethodCall (InstanceCreation []
1444 runtimeExceptionType
1445 [Lit $ String err]
1446 ( Just $ ClassBody
1447 [ MemberDecl $ MethodDecl [Public, Final]
1448 []
1449 (Just . RefType $ ClassRefType objectType)
1450 (Ident "throwSelf")
1451 []
1452 []
1453 ( MethodBody . Just $
1454 Block [ BlockStmt (Throw This) ]
1459 []
1460 (Ident "throwSelf")
1461 []
1462mkExp other = error (show other)