@@ -15,6 +15,7 @@ import Util.System
1515import Control.Applicative hiding (Const)
1616import Control.Arrow
1717import Control.Monad
18+import Control.Monad.Error
1819import qualified Control.Monad.Trans as T
1920import Control.Monad.Trans.State
2021import Data.Int
@@ -34,10 +35,8 @@ import System.FilePath
3435import System.IO
3536import System.Process
3637
37−data CodeGenerationEnv = CodeGenerationEnv { globalVariablePositions :: [(Name, Int)] }
38−
39−type CodeGeneration = StateT (CodeGenerationEnv) (Either String)
40−type BlockResultTransformation = [BlockStmt] -> Exp -> CodeGeneration [BlockStmt]
38+-----------------------------------------------------------------------
39+-- Main function
4140
4241codegenJava :: [(Name, SExp)] -> -- initialization of globals
4342 [(Name, SDecl)] ->
@@ -54,7 +53,7 @@ codegenJava globalInit defs out hdrs libs exec = do
5453 let outjava = srcdir </> clsName <.> "java"
5554 let jout = either error
5655 (prettyPrint)-- flatIndent . prettyPrint)
57− (evalStateT (mkCompilationUnit globalInit defs hdrs out) (mkCodeGenEnv globalInit))
56+ (evalStateT (mkCompilationUnit globalInit defs hdrs out) mkCodeGenEnv)
5857 writeFile outjava jout
5958 if (exec == Raw)
6059 then copyFile outjava (takeDirectory out </> clsName <.> "java")
@@ -135,15 +134,133 @@ mkPomDependencies deps =
135134-----------------------------------------------------------------------
136135-- Code generation environment
137136
138−mkCodeGenEnv :: [(Name, SExp)] -> CodeGenerationEnv
139−mkCodeGenEnv globalInit =
140− CodeGenerationEnv $ zipWith (\ (name, _) pos -> (name, pos)) globalInit [0..]
137+data CodeGenerationEnv
138+ = CodeGenerationEnv
139+ { globalVariables :: [(Name, ArrayIndex)]
140+ , localVariables :: [[(Int, Ident)]]
141+ , localVarCounter :: Int
142+ }
143+
144+type CodeGeneration = StateT (CodeGenerationEnv) (Either String)
145+
146+mkCodeGenEnv :: CodeGenerationEnv
147+mkCodeGenEnv = CodeGenerationEnv [] [] 0
148+
149+varPos :: LVar -> CodeGeneration (Either ArrayIndex Ident)
150+varPos (Loc i) = do
151+ vars <- (concat . localVariables) <$> get
152+ case lookup i vars of
153+ (Just varName) -> return (Right varName)
154+ Nothing -> throwError $ "Invalid local variable id: " ++ show i
155+varPos (Glob name) = do
156+ vars <- globalVariables <$> get
157+ case lookup name vars of
158+ (Just varIdx) -> return (Left varIdx)
159+ Nothing -> throwError $ "Invalid global variable id: " ++ show name
160+
161+pushScope :: CodeGeneration ()
162+pushScope =
163+ modify (\ env -> env { localVariables = []:(localVariables env) })
164+
165+popScope :: CodeGeneration ()
166+popScope = do
167+ env <- get
168+ let lVars = tail $ localVariables env
169+ let vC = if null lVars then 0 else localVarCounter env
170+ put $ env { localVariables = tail (localVariables env)
171+ , localVarCounter = vC }
172+
173+setVariable :: LVar -> CodeGeneration (Either ArrayIndex Ident)
174+setVariable (Loc i) = do
175+ env <- get
176+ let lVars = localVariables env
177+ let getter = localVar $ localVarCounter env
178+ let lVars' = ((i, getter) : head lVars) : tail lVars
179+ put $ env { localVariables = lVars'
180+ , localVarCounter = 1 + localVarCounter env}
181+ return (Right getter)
182+setVariable (Glob n) = do
183+ env <- get
184+ let gVars = globalVariables env
185+ let getter = globalContext @! length gVars
186+ let gVars' = (n, getter):gVars
187+ put (env { globalVariables = gVars' })
188+ return (Left getter)
189+
190+pushParams :: [Ident] -> CodeGeneration ()
191+pushParams paramNames =
192+ let varMap = zipWith (flip (,)) paramNames [0..] in
193+ modify (\ env -> env { localVariables = varMap:(localVariables env)
194+ , localVarCounter = (length varMap) + (localVarCounter env) })
141195
142196flatIndent :: String -> String
143197flatIndent (' ' : ' ' : xs) = flatIndent xs
144198flatIndent (x:xs) = x:flatIndent xs
145199flatIndent [] = []
146200
201+-----------------------------------------------------------------------
202+-- Maintaining control structures over code blocks
203+
204+data BlockPostprocessor
205+ = BlockPostprocessor
206+ { ppInnerBlock :: [BlockStmt] -> Exp -> CodeGeneration [BlockStmt]
207+ , ppOuterBlock :: [BlockStmt] -> CodeGeneration [BlockStmt]
208+ }
209+
210+ppExp :: BlockPostprocessor -> Exp -> CodeGeneration [BlockStmt]
211+ppExp pp exp = ((ppInnerBlock pp) [] exp) >>= ppOuterBlock pp
212+
213+addReturn :: BlockPostprocessor
214+addReturn =
215+ BlockPostprocessor
216+ { ppInnerBlock = (\ block exp -> return $ block ++ [jReturn exp])
217+ , ppOuterBlock = return
218+ }
219+
220+ignoreResult :: BlockPostprocessor
221+ignoreResult =
222+ BlockPostprocessor
223+ { ppInnerBlock = (\ block exp -> return block)
224+ , ppOuterBlock = return
225+ }
226+
227+ignoreOuter :: BlockPostprocessor -> BlockPostprocessor
228+ignoreOuter pp = pp { ppOuterBlock = return }
229+
230+throwRuntimeException :: BlockPostprocessor -> BlockPostprocessor
231+throwRuntimeException pp =
232+ pp
233+ { ppInnerBlock =
234+ (\ blk exp -> return $
235+ blk ++ [ BlockStmt $ Throw
236+ ( InstanceCreation
237+ []
238+ (toClassType runtimeExceptionType)
239+ [exp]
240+ Nothing
241+ )
242+ ]
243+ )
244+ }
245+
246+
247+rethrowAsRuntimeException :: BlockPostprocessor -> BlockPostprocessor
248+rethrowAsRuntimeException pp =
249+ pp
250+ { ppOuterBlock =
251+ (\ blk -> do
252+ ex <- ppInnerBlock (throwRuntimeException pp) [] (ExpName $ J.Name [Ident "ex"])
253+ ppOuterBlock pp
254+ $ [ BlockStmt $ Try
255+ (Block blk)
256+ [Catch (FormalParam [] exceptionType False (VarId (Ident "ex"))) $
257+ Block ex
258+ ]
259+ Nothing
260+ ]
261+ )
262+ }
263+
147264-----------------------------------------------------------------------
148265-- File structure
149266
@@ -206,20 +323,21 @@ mkClassBody globalInit defs =
206323
207324mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]
208325mkGlobalContext [] = return []
209−mkGlobalContext initExps =
210− (\ exps -> [ MemberDecl $ FieldDecl [Private, Static, Final]
326+mkGlobalContext initExps = do
327+ pushScope
328+ varInit <-
329+ mapM (\ (name, exp) -> do
330+ pos <- setVariable (Glob name)
331+ mkUpdate ignoreResult (Glob name) exp
332+ ) initExps
333+ popScope
334+ return [ MemberDecl $ FieldDecl [Private, Static, Final]
211335 (array objectType)
212336 [ VarDecl (VarId $ globalContextID). Just . InitExp
213337 $ ArrayCreate objectType [jInt $ length initExps] 0
214338 ]
215− , InitDecl True (Block $ concat exps)
216− ]
217− )
218− <$> mapM
219− (\ (name, exp) ->
220− mkUpdate (Glob name) exp (\ b e -> return $ addToBlock b e)
221− )
222− initExps
339+ , InitDecl True (Block $ concat varInit)
340+ ]
223341
224342addMainMethod :: [Decl] -> [Decl]
225343addMainMethod decls
@@ -280,23 +398,16 @@ mkDecl ((NS n (ns:nss)), decl) =
280398 MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
281399 <$> mangle (UN ns)
282400 <*> mkClassBody [] [(NS n nss, decl)]
283−mkDecl (_, SFun name params stackSize body) =
284− (\ (Ident name) params paramNames methodBody ->
285− simpleMethod
286− [Public, Static]
287− (Just objectType)
288− name
289− params
290− ( Block $ ( declareFinalObjectArray
291− localContextID
292− (Just (arrayInitExps $ extendWithNull paramNames stackSize))
293− ) : methodBody
294− )
295− )
296− <$> mangle name
297− <*> mapM mkFormalParam params
298− <*> mapM (\ p -> (ExpName) <$> mangleFull p) params
299− <*> mkExp body (\ block res -> return $ block ++ [jReturn res])
401+mkDecl (_, SFun name params stackSize body) = do
402+ (Ident methodName) <- mangle name
403+ methodParams <- mapM mkFormalParam params
404+ paramNames <- mapM mangle params
405+ pushParams paramNames
406+ methodBody <- mkExp addReturn body
407+ popScope
408+ return $
409+ simpleMethod [Public, Static] (Just objectType) methodName methodParams
410+ (Block methodBody)
300411
301412mkFormalParam :: Name -> CodeGeneration FormalParam
302413mkFormalParam name =
@@ -308,63 +419,66 @@ mkFormalParam name =
308419
309420-- | Compile a simple expression and use the given continuation to postprocess
310421-- the resulting value.
311−mkExp :: SExp -> BlockResultTransformation -> CodeGeneration [BlockStmt]
422+mkExp :: BlockPostprocessor -> SExp -> CodeGeneration [BlockStmt]
312423-- Variables
313−mkExp (SV var) cont = Nothing <>@! var >>= cont []
424+mkExp pp (SV var) =
425+ (Nothing <>@! var) >>= ppExp pp
314426
315427-- Applications
316−mkExp (SApp pushTail name args) cont = mkApp pushTail name args >>= cont []
428+mkExp pp (SApp pushTail name args) =
429+ mkApp pushTail name args >>= ppExp pp
317430
318431-- Bindings
319−mkExp (SLet var newExp inExp) cont = mkLet var newExp inExp cont
320−mkExp (SUpdate var newExp) cont = mkUpdate var newExp cont
432+mkExp pp (SLet var newExp inExp) =
433+ mkLet pp var newExp inExp
434+mkExp pp (SUpdate var newExp) =
435+ mkUpdate pp var newExp
321436
322437-- Objects
323−mkExp (SCon conId _ args) cont = (mkIdrisObject conId args) >>= cont []
438+mkExp pp (SCon conId _ args) =
439+ mkIdrisObject conId args >>= ppExp pp
324440
325441-- Case expressions
326−mkExp (SCase var alts) cont = mkCase True var alts cont
327−mkExp (SChkCase var alts) cont = mkCase False var alts cont
442+mkExp pp (SCase var alts) = mkCase pp True var alts
443+mkExp pp (SChkCase var alts) = mkCase pp False var alts
328444
329445-- Projections
330−mkExp (SProj var i) cont = (mkProjection var i) >>= cont []
446+mkExp pp (SProj var i) =
447+ mkProjection var i >>= ppExp pp
331448
332449-- Constants
333−mkExp (SConst c) cont = cont [] $ mkConstant c
450+mkExp pp (SConst c) =
451+ ppExp pp $ mkConstant c
334452
335453-- Foreign function calls
336−mkExp (SForeign lang resTy text params) cont =
337− (mkForeign lang resTy text params) >>= cont []
454+mkExp pp (SForeign lang resTy text params) =
455+ mkForeign pp lang resTy text params
338456
339457-- Primitive functions
340−mkExp (SOp LFork [arg]) cont = (mkThread arg) >>= cont []
341−mkExp (SOp LPar [arg]) cont = (Nothing <>@! arg) >>= cont []
342−mkExp (SOp LNoOp args) cont = (Nothing <>@! (last args)) >>= cont []
343−mkExp (SOp op args) cont = (mkPrimitiveFunction op args) >>= cont []
458+mkExp pp (SOp LFork [arg]) =
459+ (mkThread arg) >>= ppExp pp
460+mkExp pp (SOp LPar [arg]) =
461+ (Nothing <>@! arg) >>= ppExp pp
462+mkExp pp (SOp LNoOp args) =
463+ (Nothing <>@! (last args)) >>= ppExp pp
464+mkExp pp (SOp op args) =
465+ (mkPrimitiveFunction op args) >>= ppExp pp
344466
345467-- Empty expressions
346−mkExp (SNothing) cont = cont [] $ Lit Null
468+mkExp pp (SNothing) = ppExp pp $ Lit Null
347469
348470-- Errors
349−mkExp (SError err) cont = mkException err
471+mkExp pp (SError err) = ppExp (throwRuntimeException pp) (jString err)
350472
351473-----------------------------------------------------------------------
352474-- Variable access
353475
354476(<>@!) :: Maybe J.Type -> LVar -> CodeGeneration Exp
355477(<>@!) Nothing var =
356− (ArrayAccess . ((contextArray var) @!)) <$> varPos var
478+ either ArrayAccess (\ n -> ExpName $ J.Name [n]) <$> varPos var
357479(<>@!) (Just castTo) var =
358480 (castTo <>) <$> (Nothing <>@! var)
359481
360−varPos :: LVar -> CodeGeneration Int
361−varPos (Loc i) = return i
362−varPos (Glob name) = do
363− positions <- globalVariablePositions <$> get
364− case lookup name positions of
365− (Just pos) -> return pos
366− Nothing -> T.lift . Left $ "Invalid global variable id: " ++ show name
367−
368482-----------------------------------------------------------------------
369483-- Application (wrap method calls in tail call closures)
370484
@@ -386,17 +500,29 @@ mkMethodCallClosure name args =
386500-----------------------------------------------------------------------
387501-- Updates (change context array) and Let bindings (Update, execute)
388502
389−mkUpdate :: LVar -> SExp -> BlockResultTransformation -> CodeGeneration [BlockStmt]
390−mkUpdate var exp cont = do
391− pos <- varPos var
392− mkExp exp (\ blk rhs -> cont blk $ ((contextArray var) @! pos) @:= rhs )
393−
394−mkLet :: LVar -> SExp -> SExp -> BlockResultTransformation -> CodeGeneration [BlockStmt]
395−mkLet var@(Loc pos) newExp inExp cont = do
396− inBlk <- mkExp inExp cont
397− upd <- mkUpdate var newExp (\ blk exp -> return $ addToBlock blk exp)
398− return $ upd ++ inBlk
399−mkLet (Glob _) _ _ _ = T.lift $ Left "Cannot let bind to global variable"
503+mkUpdate :: BlockPostprocessor -> LVar -> SExp -> CodeGeneration [BlockStmt]
504+mkUpdate pp var exp =
505+ mkExp
506+ ( pp
507+ { ppInnerBlock =
508+ (\ blk rhs -> do
509+ pos <- setVariable var
510+ vExp <- Nothing <>@! var
511+ ppInnerBlock pp (blk ++ [pos @:= rhs]) vExp
512+ )
513+ }
514+ ) exp
515+
516+mkLet :: BlockPostprocessor -> LVar -> SExp -> SExp -> CodeGeneration [BlockStmt]
517+mkLet pp var@(Loc pos) newExp inExp =
518+ mkUpdate (pp { ppInnerBlock =
519+ (\ blk _ -> do
520+ inBlk <- mkExp pp inExp
521+ return (blk ++ inBlk)
522+ )
523+ }
524+ ) var newExp
525+mkLet _ (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"
400526
401527-----------------------------------------------------------------------
402528-- Object creation
@@ -411,30 +537,36 @@ mkIdrisObject conId args =
411537-----------------------------------------------------------------------
412538-- Case expressions
413539
414−mkCase :: Bool -> LVar -> [SAlt] -> BlockResultTransformation -> CodeGeneration [BlockStmt]
415−
416−mkCase checked var cases cont
540+mkCase :: BlockPostprocessor -> Bool -> LVar -> [SAlt] -> CodeGeneration [BlockStmt]
541+mkCase pp checked var cases
542+ | isDefaultOnlyCase cases = mkDefaultMatch pp cases
417543 | isConstCase cases = do
418− defaultStmts <- mkDefaultMatch cases cont
419− ifte <- mkConstMatch var defaultStmts cases cont
420− return [BlockStmt ifte]
421−mkCase checked var cases cont =
422− (\ switchExp blocks defaultStmts ->
423− [BlockStmt $ Switch switchExp (blocks ++ [SwitchBlock Default defaultStmts])]
424− )
425− <$> mkGetConstructorId checked var
426− <*> mkConsMatch var cases cont
427− <*> mkDefaultMatch cases cont
544+ ifte <- mkConstMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
545+ ppOuterBlock pp [BlockStmt ifte]
546+ | otherwise = do
547+ switchExp <- mkGetConstructorId checked var
548+ matchBlocks <- mkConsMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
549+ ppOuterBlock pp [BlockStmt $ Switch switchExp matchBlocks]
428550
429551isConstCase :: [SAlt] -> Bool
430552isConstCase ((SConstCase _ _):_) = True
431553isConstCase ((SDefaultCase _):cases) = isConstCase cases
432554isConstCase _ = False
433555
434−mkDefaultMatch :: [SAlt] -> BlockResultTransformation -> CodeGeneration [BlockStmt]
435−mkDefaultMatch (x@(SDefaultCase branchExpression):_) cont = mkExp branchExpression cont
436−mkDefaultMatch (x:xs) cont = mkDefaultMatch xs cont
437−mkDefaultMatch [] cont = mkException "Non-exhaustive pattern"
556+isDefaultOnlyCase :: [SAlt] -> Bool
557+isDefaultOnlyCase [SDefaultCase _] = True
558+isDefaultOnlyCase [] = True
559+isDefaultOnlyCase _ = False
560+
561+mkDefaultMatch :: BlockPostprocessor -> [SAlt] -> CodeGeneration [BlockStmt]
562+mkDefaultMatch pp (x@(SDefaultCase branchExpression):_) =
563+ do pushScope
564+ stmt <- mkExp pp branchExpression
565+ popScope
566+ return stmt
567+mkDefaultMatch pp (x:xs) = mkDefaultMatch pp xs
568+mkDefaultMatch pp [] =
569+ ppExp (throwRuntimeException pp) (jString "Non-exhaustive pattern")
438570
439571mkMatchConstExp :: LVar -> Const -> CodeGeneration Exp
440572mkMatchConstExp var c
@@ -454,14 +586,23 @@ mkMatchConstExp var c
454586 cty = constType c
455587 jc = mkConstant c
456588
457−mkConstMatch :: LVar -> [BlockStmt] -> [SAlt] -> BlockResultTransformation -> CodeGeneration Stmt
458−mkConstMatch var defaultStmts ((SConstCase constant branchExpression):cases) cont =
459− (\ exp block others -> IfThenElse exp (StmtBlock $ Block block) others)
460− <$> mkMatchConstExp var constant
461− <*> mkExp branchExpression cont
462− <*> mkConstMatch var defaultStmts cases cont
463−mkConstMatch var defaultStmts (c:cases) cont = mkConstMatch var defaultStmts cases cont
464−mkConstMatch var defaultStmts [] cont = return $ StmtBlock (Block defaultStmts)
589+mkConstMatch :: BlockPostprocessor ->
590+ (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
591+ LVar ->
592+ [SAlt] ->
593+ CodeGeneration Stmt
594+mkConstMatch pp getDefaultStmts var ((SConstCase constant branchExpression):cases) = do
595+ matchExp <- mkMatchConstExp var constant
596+ pushScope
597+ branchBlock <- mkExp pp branchExpression
598+ popScope
599+ otherBranches <- mkConstMatch pp getDefaultStmts var cases
600+ return
601+ $ IfThenElse matchExp (StmtBlock $ Block branchBlock) otherBranches
602+mkConstMatch pp getDefaultStmts var (c:cases) = mkConstMatch pp getDefaultStmts var cases
603+mkConstMatch pp getDefaultStmts _ [] = do
604+ defaultBlock <- getDefaultStmts pp
605+ return $ StmtBlock (Block defaultBlock)
465606
466607mkGetConstructorId :: Bool -> LVar -> CodeGeneration Exp
467608mkGetConstructorId True var =
@@ -474,26 +615,34 @@ mkGetConstructorId False var =
474615 <$> (Nothing <>@! var)
475616 <*> mkGetConstructorId True var
476617
477−mkConsMatch :: LVar -> [SAlt] -> BlockResultTransformation -> CodeGeneration [SwitchBlock]
478−mkConsMatch var ((SConCase parentStackPos consIndex _ params branchExpression):cases) cont =
479− (\ block others -> (SwitchBlock (SwitchCase $ jInt consIndex) block):others)
480− <$> mkCaseBinding var parentStackPos params branchExpression cont
481− <*> mkConsMatch var cases cont
482−mkConsMatch var (_:cases) cont = mkConsMatch var cases cont
483−mkConsMatch _ [] _ = return []
484−
485−mkCaseBinding :: LVar -> Int -> [Name] -> SExp -> BlockResultTransformation -> CodeGeneration [BlockStmt]
486−mkCaseBinding var stackStart [] branchExpression cont = mkExp branchExpression cont
487−mkCaseBinding var stackStart (params) branchExpression cont = do
488− deconstruction <- mkCaseBindingDeconstruction var stackStart params
489− branchBlk <- mkExp branchExpression cont
490− return $ deconstruction ++ branchBlk
491−
492−mkCaseBindingDeconstruction :: LVar -> Int -> [Name] -> CodeGeneration [BlockStmt]
493−mkCaseBindingDeconstruction var stackStart members =
494− mapM (\ pos -> BlockStmt . ExpStmt .
495− ((contextArray var @! (stackStart + pos)) @:=) <$> mkProjection var pos
496− ) ([0..(length members - 1)])
618+mkConsMatch :: BlockPostprocessor ->
619+ (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
620+ LVar ->
621+ [SAlt] ->
622+ CodeGeneration [SwitchBlock]
623+mkConsMatch pp getDefaultStmts var ((SConCase parentStackPos consIndex _ params branchExpression):cases) = do
624+ pushScope
625+ caseBranch <- mkCaseBinding pp var parentStackPos params branchExpression
626+ popScope
627+ otherBranches <- mkConsMatch pp getDefaultStmts var cases
628+ return $
629+ (SwitchBlock (SwitchCase $ jInt consIndex) caseBranch):otherBranches
630+mkConsMatch pp getDefaultStmts var (c:cases) = mkConsMatch pp getDefaultStmts var cases
631+mkConsMatch pp getDefaultStmts _ [] = do
632+ defaultBlock <- getDefaultStmts pp
633+ return $
634+ [SwitchBlock Default defaultBlock]
635+
636+mkCaseBinding :: BlockPostprocessor -> LVar -> Int -> [Name] -> SExp -> CodeGeneration [BlockStmt]
637+mkCaseBinding pp var stackStart params branchExpression =
638+ mkExp pp (toLetIn var stackStart params branchExpression)
639+ where
640+ toLetIn :: LVar -> Int -> [Name] -> SExp -> SExp
641+ toLetIn var stackStart members start =
642+ foldr
643+ (\ pos inExp -> SLet (Loc (stackStart + pos)) (SProj var pos) inExp)
644+ start
645+ [0.. (length members - 1)]
497646
498647-----------------------------------------------------------------------
499648-- Projection (retrieve the n-th field of an object)
@@ -536,51 +685,31 @@ mkConstant c@(Forgot ) = ClassLit (Just $ objectType)
536685-----------------------------------------------------------------------
537686-- Foreign function calls
538687
539−mkForeignWrappedMethod :: FCallType -> FType -> String -> [(FType, LVar)] -> CodeGeneration Decl
540−mkForeignWrappedMethod callType resTy text params
541− | callType <- FStatic =
542− (\ method args ->
543− wrapperMethod $ wrapReturn resTy (call method args)
544− )
545− <$> liftParsed (parser name text)
546− <*> foreignVarAccess params
547− | callType <- FObject =
548− (\ method (tgt:args) ->
549− wrapperMethod $ wrapReturn resTy ((tgt ~> (show $ pretty method)) args)
550− )
551− <$> liftParsed (parser ident text)
552− <*> foreignVarAccess params
553− | callType <- FConstructor =
554− (\ clsTy args ->
555− wrapperMethod $ wrapReturn resTy (InstanceCreation [] clsTy args Nothing)
556− )
557− <$> liftParsed (parser classType text)
558− <*> foreignVarAccess params
688+mkForeign :: BlockPostprocessor -> FLang -> FType -> String -> [(FType, LVar)] -> CodeGeneration [BlockStmt]
689+mkForeign pp (LANG_C) resTy text params = mkForeign pp (LANG_JAVA FStatic) resTy text params
690+mkForeign pp (LANG_JAVA callType) resTy text params
691+ | callType <- FStatic = do
692+ method <- liftParsed (parser name text)
693+ args <- foreignVarAccess params
694+ wrapReturn resTy (call method args)
695+ | callType <- FObject = do
696+ method <- liftParsed (parser ident text)
697+ (tgt:args) <- foreignVarAccess params
698+ wrapReturn resTy ((tgt ~> (show $ pretty method)) args)
699+ | callType <- FConstructor = do
700+ clsTy <- liftParsed (parser classType text)
701+ args <- foreignVarAccess params
702+ wrapReturn resTy (InstanceCreation [] clsTy args Nothing)
559703 where
560− wrapperMethod =
561− MemberDecl . MethodDecl
562− [Protected, Final] [] (Just objectType) (Ident $ "wrappedInvoke") [] [toRefType exceptionType]
563− . MethodBody . Just . Block
564−
565−
566− wrapReturn FUnit exp = [ BlockStmt $ ExpStmt exp, jReturn (Lit Null) ]
567− wrapReturn _ exp = [ jReturn exp ]
568−
569704 foreignVarAccess args =
570705 mapM (\ (fty, var) -> (foreignType fty <>@! var)) args
571706
572−mkForeign :: FLang -> FType -> String -> [(FType, LVar)] -> CodeGeneration Exp
573−mkForeign (LANG_JAVA callType) resTy text params =
574− (\ wrappedMethod ->
575− ((InstanceCreation
576− []
577− (toClassType foreignWrapperType)
578− []
579− (Just $ ClassBody [wrappedMethod])
580− ) ~> "invoke") []
581− )
582− <$> mkForeignWrappedMethod callType resTy text params
583−mkForeign (LANG_C) resTy text params = mkForeign (LANG_JAVA FStatic) resTy text params
707+ pp' = rethrowAsRuntimeException pp
708+
709+ wrapReturn FUnit exp =
710+ ((ppInnerBlock pp') [BlockStmt $ ExpStmt exp] (Lit Null)) >>= ppOuterBlock pp'
711+ wrapReturn _ exp =
712+ ((ppInnerBlock pp') [] exp) >>= ppOuterBlock pp'
584713
585714-----------------------------------------------------------------------
586715-- Primitive functions
@@ -594,18 +723,4 @@ mkThread :: LVar -> CodeGeneration Exp
594723mkThread arg =
595724 (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (MN 0 "EVAL") [arg]
596725
597−-----------------------------------------------------------------------
598−-- Exceptions
599−
600−mkException :: String -> CodeGeneration [BlockStmt]
601−mkException err =
602− return $
603− [ BlockStmt $ Throw
604− ( InstanceCreation
605− []
606− (toClassType runtimeExceptionType)
607− [Lit $ String err]
608− Nothing
609− )
610− ]
611726