@@ -14,6 +14,7 @@ import Util.System
1414import Control.Arrow
1515import Data.Char
1616import Data.List
17+import Data.Maybe
1718import System.IO
1819import System.Directory
1920
@@ -321,27 +322,50 @@ translateConstant c =
321322translateDeclaration :: (String, SDecl) -> JS
322323translateDeclaration (path, SFun name params stackSize body)
323324 | (MN _ "APPLY") <- name =
324− JSSeq [ JSRaw $ "/* " ++ translateName name ++ " */"
325− , jsDecl (path ++ translateName name) $ translate params stackSize body
326− ]
325+ let fun = translateExpression body in
326+ jsDecl $ jsFun fun
327327 | (MN _ "EVAL") <- name
328328 , (SChkCase var cases) <- body =
329− JSSeq [ JSRaw $ "/* " ++ translateName name ++ " */"
330− , jsDecl (path ++ translateName name) $ translate params stackSize body
331− ]
329+ let fun = translateExpression body in
330+ JSSeq [ lookupTable var cases
331+ , jsDecl $ JSRaw $ concat [ "function(arg0){"
332+ , "if (arg0 instanceof __IDRRT__Con "
333+ , " && LOOKUPTABLE.hasOwnProperty(arg0.tag))"
334+ , "return LOOKUPTABLE[arg0.tag](arg0);"
335+ , "else "
336+ , "return arg0; }"
337+ ]
338+ ]
332339 | otherwise =
333− jsDecl (path ++ translateName name) $ translate params stackSize body
340+ let fun = translateExpression body in
341+ jsDecl $ jsFun fun
342+
334343 where
335− jsDecl :: String -> JS -> JS
336− jsDecl name = JSAlloc name . Just
344+ caseFun :: LVar -> SAlt -> JS
345+ caseFun var cse =
346+ jsFun (translateCase (Just (translateVariableName var)) cse)
347+
348+ getTag :: SAlt -> Maybe String
349+ getTag (SConCase _ tag _ _ _) = Just $ show tag
350+ getTag _ = Nothing
351+
352+ lookupTable :: LVar -> [SAlt] -> JS
353+ lookupTable var cases =
354+ JSAlloc "LOOKUPTABLE" $ Just $ JSObject $ catMaybes $ map (lookupEntry var) cases
355+
356+ lookupEntry :: LVar -> SAlt -> Maybe (String, JS)
357+ lookupEntry var alt = getTag alt >>= \tag -> Just (tag, caseFun var alt)
358+
359+ jsDecl :: JS -> JS
360+ jsDecl = JSAlloc (path ++ translateName name) . Just
337361
338− translate :: [Name] -> Int -> SExp -> JS
339− translate params stackSize body =
362+ jsFun :: JS -> JS
363+ jsFun body =
340364 JSFunction p (
341365 JSSeq $
342366 zipWith assignVar [0..] p ++
343367 map allocVar [numP .. (numP + stackSize - 1)] ++
344− [JSReturn $ translateExpression body]
368+ [JSReturn body]
345369 )
346370 where
347371 numP :: Int