@@ -33,15 +33,16 @@ data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]
3333
3434
3535initCompileInfo :: [(Name, [BC])] -> CompileInfo
36−initCompileInfo bc = CompileInfo (collectApplyCases bc) []
36+initCompileInfo bc =
37+ CompileInfo (collectCases "APPLY" bc) (collectCases "EVAL" bc)
3738 where
38− collectApplyCases :: [(Name, [BC])] -> [Int]
39− collectApplyCases bc = getCases $ findApply bc
39+ collectCases :: String -> [(Name, [BC])] -> [Int]
40+ collectCases fun bc = getCases $ findFunction fun bc
4041
41− findApply :: [(Name, [BC])] -> [BC]
42− findApply ((MN 0 fun, bc):_)
43− | fun == txt "APPLY" = bc
44− findApply (_:bc) = findApply bc
42+ findFunction :: String -> [(Name, [BC])] -> [BC]
43+ findFunction f ((MN 0 fun, bc):_)
44+ | fun == txt f = bc
45+ findFunction f (_:bc) = findFunction f bc
4546
4647 getCases :: [BC] -> [Int]
4748 getCases = concatMap analyze
@@ -343,7 +344,7 @@ translateDecl info (name@(MN 0 fun), bc)
343344 translateName name
344345 ) (Just $ JSFunction ["vm", "oldbase"] (
345346 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
346− JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON"
347+ JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")
347348 , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [ JSIdent "vm"
348349 , JSIdent "oldbase"
349350 , JSIdent "myoldbase"
@@ -357,6 +358,27 @@ translateDecl info (name@(MN 0 fun), bc)
357358 )
358359 )
359360 ]
361+
362+ | txt "EVAL" == fun =
363+ allocCaseFunctions (snd body)
364+ ++ [ JSAlloc (
365+ translateName name
366+ ) (Just $ JSFunction ["vm", "oldbase"] (
367+ JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
368+ JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
369+ , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [ JSIdent "vm"
370+ , JSIdent "oldbase"
371+ , JSIdent "myoldbase"
372+ ]
373+ )
374+ , ( JSNoop
375+ , JSSeq $ map (translateBC info) (defaultCase (snd body))
376+ )
377+ ]
378+ ]
379+ )
380+ )
381+ ]
360382 where
361383 body :: ([BC], [BC])
362384 body = break isCase bc
@@ -568,6 +590,9 @@ jsMKCON info r t rs =
568590 , if t `elem` compileInfoApplyCases info
569591 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
570592 else JSNull
593+ , if t `elem` compileInfoEvalCases info
594+ then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
595+ else JSNull
571596 ]
572597 )
573598
@@ -638,11 +663,9 @@ jsCASE info safe reg cases def =
638663
639664 jsTAG :: JS -> JS
640665 jsTAG js =
641− JSTernary (jsIsNumber js `jsOr` jsIsNull js) (
642− JSNum (JSInt $ negate 1)
643− ) (JSTernary (js `jsInstanceOf` "i$CON") (
644− JSProj js "tag"
645− ) (JSNum (JSInt $ negate 1)))
666+ (JSTernary (js `jsInstanceOf` "i$CON") (
667+ JSProj js "tag"
668+ ) (JSNum (JSInt $ negate 1)))
646669
647670 jsCTAG :: JS -> JS
648671 jsCTAG js = JSProj js "tag"