@@ -14,6 +14,7 @@ import Util.System
1414import Control.Arrow
1515import Control.Applicative ((<$>), (<*>), pure)
1616import Data.Char
17+import Numeric
1718import Data.List
1819import Data.Maybe
1920import System.IO
@@ -71,7 +72,6 @@ data JS = JSRaw String
7172 | JSFalse
7273 | JSArray [JS]
7374 | JSString String
74− | JSChar String
7575 | JSNum JSNum
7676 | JSAssign JS JS
7777 | JSAlloc String (Maybe JS)
@@ -162,10 +162,7 @@ compileJS (JSArray elems) =
162162 "[" ++ intercalate "," (map compileJS elems) ++ "]"
163163
164164compileJS (JSString str) =
165− show str
166−
167−compileJS (JSChar chr) =
168− chr
165+ "\"" ++ str ++ "\""
169166
170167compileJS (JSNum num)
171168 | JSInt i <- num = show i
@@ -186,8 +183,8 @@ compileJS (JSIndex lhs rhs) =
186183compileJS (JSCond branches) =
187184 intercalate " else " $ map createIfBlock branches
188185 where
189− createIfBlock (JSTrue, e) =
190− "if (true) {\n"
186+ createIfBlock (JSNoop, e) =
187+ "{\n"
191188 ++ compileJS e
192189 ++ ";\n}"
193190 createIfBlock (cond, e) =
@@ -420,7 +417,6 @@ removeAllocations js = transformJS removeAllocations js
420417isJSConstant :: JS -> Bool
421418isJSConstant js
422419 | JSString _ <- js = True
423− | JSChar _ <- js = True
424420 | JSNum _ <- js = True
425421 | JSType _ <- js = True
426422 | JSNull <- js = True
@@ -448,82 +444,103 @@ isJSConstantConstructor constants js
448444
449445
450446inlineJS :: JS -> JS
451−inlineJS (JSReturn (JSApp (JSFunction [] err@(JSError _)) [])) = err
452−inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =
453− inlineJS $ jsSubst (JSIdent "cse") val body
447+inlineJS = inlineAssign . inlineError . inlineApply . inlineCaseMatch . inlineJSLet
448+ where
449+ inlineJSLet :: JS -> JS
450+ inlineJSLet (JSApp (JSFunction [arg] (JSReturn ret)) [val])
451+ | opt <- inlineJSLet val =
452+ inlineJS $ jsSubst (JSIdent arg) opt ret
454453
454+ inlineJSLet js = transformJS inlineJSLet js
455455
456−inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =
457− inlineJS $ JSSeq [ JSAlloc arg (Just val)
458− , cond
459− ]
460456
461−inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
462− JSThis,JSProj var "vars"
463− ])
464− | var /= JSIdent "cse" =
465− inlineJS $ inlineApply args body 0
457+ inlineCaseMatch (JSReturn (JSApp (JSFunction ["cse"] body) [val]))
458+ | opt <- inlineCaseMatch val =
459+ inlineCaseMatch $ jsSubst (JSIdent "cse") opt body
460+
461+ inlineCaseMatch js = transformJS inlineCaseMatch js
462+
463+
464+ inlineApply js
465+ | JSApp (
466+ JSProj (JSFunction args (JSReturn body)) "apply"
467+ ) [JSThis, JSProj var "vars"] <- js =
468+ inlineApply $ inlineApply' var args body 0
469+ | JSReturn (JSApp (
470+ JSProj (JSFunction args body@(JSCond _)) "apply"
471+ ) [JSThis, JSProj var "vars"]) <- js =
472+ inlineApply $ inlineApply' var args body 0
473+ where
474+ inlineApply' _ [] body _ = body
475+ inlineApply' var (a:as) body n =
476+ inlineApply' var as (
477+ jsSubst (JSIdent a) (
478+ JSIndex (JSProj var "vars") (JSNum (JSInt n))
479+ ) body
480+ ) (n + 1)
481+
482+ inlineApply js = transformJS inlineApply js
483+
484+
485+ inlineError (JSReturn (JSApp (JSFunction [] error@(JSError _)) [])) =
486+ inlineError error
487+
488+ inlineError js = transformJS inlineError js
489+
490+
491+ inlineAssign (JSAssign lhs rhs)
492+ | JSVar _ <- lhs
493+ , JSVar _ <- rhs
494+ , lhs == rhs =
495+ lhs
496+
497+ inlineAssign (JSAssign lhs rhs)
498+ | JSIdent _ <- lhs
499+ , JSIdent _ <- rhs
500+ , lhs == rhs =
501+ lhs
502+
503+ inlineAssign js = transformJS inlineAssign js
504+
505+
506+removeEval :: [JS] -> [JS]
507+removeEval js =
508+ let (ret, isReduced) = checkEval js in
509+ if isReduced
510+ then removeEvalApp ret
511+ else ret
466512 where
467− inlineApply [] body _ = inlineJS body
468− inlineApply (a:as) body n =
469− inlineApply as (
470− jsSubst (JSIdent a) (JSIndex (JSProj var "vars") (JSNum (JSInt n))) body
471− ) (n + 1)
472−
473−inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
474− | isJSConstant val = val
475−
476−inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [
477− JSFunction [] (JSReturn val)
478− ])
479− | isJSConstant val = val
480−
481−inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
482− | JSNew con [tag, vals] <- ret
483− , opt <- inlineJS val =
484− inlineJS $ JSNew con [tag, inlineJS $ jsSubst (JSIdent arg) opt vals]
485−
486− | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
487− , opt <- inlineJS val =
488− inlineJS $ JSNew con [JSFunction [] (
489− JSReturn (
490− JSApp (
491− inlineJS $ jsSubst (JSIdent arg) opt fun
492− ) (
493− map (inlineJS . jsSubst (JSIdent arg) opt) vars
494− )
495− )
496− )]
497−
498− | JSApp (JSProj obj field) args <- ret
499− , opt <- inlineJS val =
500− inlineJS $ JSApp (
501− inlineJS $ JSProj (jsSubst (JSIdent arg) opt obj) field
502− ) (
503− map (inlineJS . jsSubst (JSIdent arg) opt) args
504− )
513+ removeEvalApp js = catMaybes (map removeEvalApp' js)
514+ where
515+ removeEvalApp' :: JS -> Maybe JS
516+ removeEvalApp' (JSAlloc "__IDR__mEVAL0" _) = Nothing
517+ removeEvalApp' js = Just $ transformJS match js
518+ where
519+ match (JSApp (JSIdent "__IDR__mEVAL0") [val]) = val
520+ match js = transformJS match js
521+
522+ removeEvalApp js = js
505523
506− | JSIndex (JSProj obj field) idx <- ret
507− , opt <- inlineJS val =
508− inlineJS $ JSIndex (JSProj (
509− inlineJS $ jsSubst (JSIdent arg) opt obj
510− ) field
511− ) (inlineJS $ jsSubst (JSIdent arg) opt idx)
524+ checkEval :: [JS] -> ([JS], Bool)
525+ checkEval js = foldr f ([], False) $ map checkEval' js
526+ where
527+ f :: (Maybe JS, Bool) -> ([JS], Bool) -> ([JS], Bool)
528+ f (Just js, isReduced) (ret, b) = (js : ret, isReduced || b)
529+ f (Nothing, isReduced) (ret, b) = (ret, isReduced || b)
512530
513− | JSBinOp op lhs rhs <- ret
514− , opt <- inlineJS val =
515− inlineJS $ JSBinOp op (inlineJS $ jsSubst (JSIdent arg) opt lhs) $
516− (inlineJS $ jsSubst (JSIdent arg) opt rhs)
517531
518− | JSApp (JSIdent fun) args <- ret
519− , opt <- inlineJS val =
520− inlineJS $ JSApp (JSIdent fun) $ map (inlineJS . jsSubst (JSIdent arg) opt) args
532+ checkEval' :: JS -> (Maybe JS, Bool)
533+ checkEval' (JSAlloc "__IDRLT__EVAL" (Just (JSApp (JSFunction [] (
534+ JSSeq [ _
535+ , JSReturn (JSIdent "t")
536+ ]
537+ )) []))) = (Nothing, True)
521538
522−inlineJS js = transformJS inlineJS js
539+ checkEval' js = (Just js, False)
523540
524541
525542reduceJS :: [JS] -> [JS]
526−reduceJS js = reduceLoop [] ([], js)
543+reduceJS js = moveJSDeclToTop "__IDRRT__Con" $ reduceLoop [] ([], js)
527544
528545
529546funName :: JS -> String
@@ -724,14 +741,29 @@ inlineFunctions js =
724741
725742
726743reduceContinuations :: JS -> JS
727−reduceContinuations = transformJS reduceHelper
744+reduceContinuations = inlineTC . reduceJS
728745 where
729− reduceHelper :: JS -> JS
730− reduceHelper (JSNew "__IDRRT__Cont" [JSFunction [] (
746+ reduceJS :: JS -> JS
747+ reduceJS (JSNew "__IDRRT__Cont" [JSFunction [] (
731748 JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])
732− )]) = js
749+ )]) = reduceJS js
750+
751+ reduceJS js = transformJS reduceJS js
752+
753+
754+ inlineTC :: JS -> JS
755+ inlineTC js
756+ | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
757+ JSReturn (JSNew "__IDRRT__Cont" [JSFunction [] (
758+ JSReturn ret@(JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
759+ JSReturn (JSNew "__IDRRT__Cont" _)
760+ )])
761+ )])
762+ )] <- js = inlineTC ret
763+
764+ inlineTC js = transformJS inlineTC js
765+
733766
734− reduceHelper js = transformJS reduceHelper js
735767
736768
737769reduceConstant :: JS -> JS
@@ -822,19 +854,16 @@ optimizeRuntimeCalls fun tc js =
822854
823855 optTC tc@"__IDRRT__APPLYTC" =
824856 JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (
825− JSSeq [ JSAlloc "ev" $ Just (JSApp
826− (JSIdent "__IDRRT__EVALTC") [JSIdent "fn0"]
827− )
828− , JSAlloc "ret" $ Just (
857+ JSSeq [ JSAlloc "ret" $ Just (
829858 JSTernary (
830− (JSIdent "ev" `jsInstanceOf` jsCon) `jsAnd`
831− (hasProp "__IDRLT__APPLY" "ev")
859+ (JSIdent "fn0" `jsInstanceOf` jsCon) `jsAnd`
860+ (hasProp "__IDRLT__APPLY" "fn0")
832861 ) (JSApp
833862 (JSIndex
834863 (JSIdent "__IDRLT__APPLY")
835− (JSProj (JSIdent "ev") "tag")
864+ (JSProj (JSIdent "fn0") "tag")
836865 )
837− [JSIdent "fn0", JSIdent "arg0", JSIdent "ev"]
866+ [JSIdent "fn0", JSIdent "arg0", JSIdent "fn0"]
838867 ) JSNull
839868 )
840869 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
@@ -861,23 +890,129 @@ unfoldLookupTable input =
861890 where
862891 adaptRuntime :: [JS] -> [JS]
863892 adaptRuntime =
864− adaptCon . adaptApply "__var_2" . adaptApply "ev" . adaptEval
893+ adaptEvalTC . adaptApplyTC . adaptEval . adaptApply . adaptCon
865894
866895
867− adaptApply var = map (jsSubst (
868− JSIndex (JSIdent "__IDRLT__APPLY") (JSProj (JSIdent var) "tag")
869− ) (JSProj (JSIdent var) "app"))
896+ adaptApply :: [JS] -> [JS]
897+ adaptApply js = adaptApply' [] js
898+ where
899+ adaptApply' :: [JS] -> [JS] -> [JS]
900+ adaptApply' front ((JSAlloc "__IDR__mAPPLY0" (Just _)):back) =
901+ front ++ (new:back)
902+
903+ adaptApply' front (next:back) =
904+ adaptApply' (front ++ [next]) back
905+
906+ adaptApply' front [] = front
907+
908+ new =
909+ JSAlloc "__IDR__mAPPLY0" (Just $ JSFunction ["mfn0", "marg0"] (JSReturn $
910+ JSTernary (
911+ (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
912+ (JSProj (JSIdent "mfn0") "app")
913+ ) (JSApp
914+ (JSProj (JSIdent "mfn0") "app")
915+ [JSIdent "mfn0", JSIdent "marg0"]
916+ ) JSNull
917+ )
918+ )
870919
871920
872− adaptEval = map (jsSubst (
873− JSIndex (JSIdent "__IDRLT__EVAL") (JSProj (JSIdent "arg0") "tag")
874− ) (JSProj (JSIdent "arg0") "eval"))
921+ adaptApplyTC :: [JS] -> [JS]
922+ adaptApplyTC js = adaptApplyTC' [] js
923+ where
924+ adaptApplyTC' :: [JS] -> [JS] -> [JS]
925+ adaptApplyTC' front ((JSAlloc "__IDRRT__APPLYTC" (Just _)):back) =
926+ front ++ (new:back)
927+
928+ adaptApplyTC' front (next:back) =
929+ adaptApplyTC' (front ++ [next]) back
930+
931+ adaptApplyTC' front [] = front
932+
933+ new =
934+ JSAlloc "__IDRRT__APPLYTC" (Just $ JSFunction ["mfn0", "marg0"] (
935+ JSSeq [ JSAlloc "ret" $ Just (
936+ JSTernary (
937+ (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
938+ (JSProj (JSIdent "mfn0") "app")
939+ ) (JSApp
940+ (JSProj (JSIdent "mfn0") "app")
941+ [JSIdent "mfn0", JSIdent "marg0"]
942+ ) JSNull
943+ )
944+ , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
945+ JSAssign (JSIdent "ret") (
946+ JSApp (JSProj (JSIdent "ret") "k") []
947+ )
948+ )
949+ , JSReturn $ JSIdent "ret"
950+ ]
951+ ))
952+
953+
954+ adaptEval :: [JS] -> [JS]
955+ adaptEval js = adaptEval' [] js
956+ where
957+ adaptEval' :: [JS] -> [JS] -> [JS]
958+ adaptEval' front ((JSAlloc "__IDR__mEVAL0" (Just _)):back) =
959+ front ++ (new:back)
960+
961+ adaptEval' front (next:back) =
962+ adaptEval' (front ++ [next]) back
963+
964+ adaptEval' front [] = front
965+
966+ new =
967+ JSAlloc "__IDR__mEVAL0" (Just $ JSFunction ["marg0"] (JSReturn $
968+ JSTernary (
969+ (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
970+ (JSProj (JSIdent "marg0") "eval")
971+ ) (JSApp
972+ (JSProj (JSIdent "marg0") "eval")
973+ [JSIdent "marg0"]
974+ ) (JSIdent "marg0")
975+ )
976+ )
977+
978+
979+ adaptEvalTC :: [JS] -> [JS]
980+ adaptEvalTC js = adaptEvalTC' [] js
981+ where
982+ adaptEvalTC' :: [JS] -> [JS] -> [JS]
983+ adaptEvalTC' front ((JSAlloc "__IDRRT__EVALTC" (Just _)):back) =
984+ front ++ (new:back)
985+
986+ adaptEvalTC' front (next:back) =
987+ adaptEvalTC' (front ++ [next]) back
988+
989+ adaptEvalTC' front [] = front
990+
991+ new =
992+ JSAlloc "__IDRRT__EVALTC" (Just $ JSFunction ["marg0"] (
993+ JSSeq [ JSAlloc "ret" $ Just (
994+ JSTernary (
995+ (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
996+ (JSProj (JSIdent "marg0") "eval")
997+ ) (JSApp
998+ (JSProj (JSIdent "marg0") "eval")
999+ [JSIdent "marg0"]
1000+ ) (JSIdent "marg0")
1001+ )
1002+ , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
1003+ JSAssign (JSIdent "ret") (
1004+ JSApp (JSProj (JSIdent "ret") "k") []
1005+ )
1006+ )
1007+ , JSReturn $ JSIdent "ret"
1008+ ]
1009+ ))
8751010
8761011
8771012 adaptCon js =
8781013 adaptCon' [] js
8791014 where
880− adaptCon' front ((JSAlloc "__IDRRT__Con" (Just body)):back) =
1015+ adaptCon' front ((JSAlloc "__IDRRT__Con" (Just _)):back) =
8811016 front ++ (new:back)
8821017
8831018 adaptCon' front (next:back) =
@@ -970,8 +1105,8 @@ removeInstanceChecks (JSCond conds) =
9701105 removeHelper js = js
9711106
9721107
973− eliminateDeadBranches (e@(JSTrue, _):_) = [e]
974− eliminateDeadBranches [(_, js)] = [(JSTrue, js)]
1108+ eliminateDeadBranches ((JSTrue, cond):_) = [(JSNoop, cond)]
1109+ eliminateDeadBranches [(_, js)] = [(JSNoop, js)]
9751110 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
9761111 eliminateDeadBranches [] = []
9771112
@@ -1022,15 +1157,6 @@ reduceLoop reduced (cons, program) =
10221157 reduceCall funs js = transformJS (reduceCall funs) js
10231158
10241159
1025−optimizeJS :: JS -> JS
1026−optimizeJS = inlineLoop
1027− where inlineLoop :: JS -> JS
1028− inlineLoop js
1029− | opt <- inlineJS js
1030− , opt /= js = inlineLoop opt
1031− | otherwise = js
1032−
1033−
10341160extractLocalConstructors :: [JS] -> [JS]
10351161extractLocalConstructors js =
10361162 concatMap extractLocalConstructors' js
@@ -1243,24 +1369,25 @@ codegenJavaScript target definitions filename outputType = do
12431369 compile =
12441370 map compileJS
12451371
1246− opt = []
1247− {-[ map optimizeJS-}
1248− {-, removeIDs-}
1249− {-, reduceJS-}
1250− {-, map reduceConstants-}
1251− {-, initConstructors-}
1252− {-, map removeAllocations-}
1253− {-, elimDeadLoop-}
1254− {-, map elimDuplicateEvals-}
1255− {-, optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"-}
1256− {-, optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"-}
1257− {-, map removeInstanceChecks-}
1258− {-, inlineFunctions-}
1259− {-, map reduceContinuations-}
1260− {-, extractLocalConstructors-}
1261− {-, unfoldLookupTable-}
1262− {-, evalCons-}
1263− {-]-}
1372+ opt =
1373+ [ removeEval
1374+ , map inlineJS
1375+ , removeIDs
1376+ , reduceJS
1377+ , map reduceConstants
1378+ , initConstructors
1379+ , map removeAllocations
1380+ , elimDeadLoop
1381+ , map elimDuplicateEvals
1382+ , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"
1383+ , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"
1384+ , map removeInstanceChecks
1385+ , inlineFunctions
1386+ , map reduceContinuations
1387+ , extractLocalConstructors
1388+ , unfoldLookupTable
1389+ , evalCons
1390+ ]
12641391
12651392 prelude :: [JS]
12661393 prelude =
@@ -1400,11 +1527,8 @@ translateSpecialName name
14001527translateConstant :: Const -> JS
14011528translateConstant (I i) = JSNum (JSInt i)
14021529translateConstant (Fl f) = JSNum (JSFloat f)
1403−translateConstant (Ch '\DEL') = JSChar "'\\u007F'"
1404−translateConstant (Ch '\a') = JSChar "'\\u0007'"
1405−translateConstant (Ch '\SO') = JSChar "'\\u000E'"
1406−translateConstant (Ch c) = JSString [c]
1407−translateConstant (Str s) = JSString s
1530+translateConstant (Ch c) = JSString $ translateChar c
1531+translateConstant (Str s) = JSString $ concatMap translateChar s
14081532translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
14091533translateConstant StrType = JSType JSStringTy
14101534translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
@@ -1417,44 +1541,72 @@ translateConstant c =
14171541 jsError $ "Unimplemented Constant: " ++ show c
14181542
14191543
1544+translateChar :: Char -> String
1545+translateChar ch
1546+ | '\a' <- ch = "\\u0007"
1547+ | '\b' <- ch = "\\b"
1548+ | '\f' <- ch = "\\f"
1549+ | '\n' <- ch = "\\n"
1550+ | '\r' <- ch = "\\r"
1551+ | '\t' <- ch = "\\t"
1552+ | '\v' <- ch = "\\v"
1553+ | '\SO' <- ch = "\\u000E"
1554+ | '\DEL' <- ch = "\\u007F"
1555+ | '\\' <- ch = "\\\\"
1556+ | '\"' <- ch = "\\\""
1557+ | '\'' <- ch = "\\\'"
1558+ | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "")
1559+ | otherwise = [ch]
1560+ where
1561+ fill :: String -> String
1562+ fill s = if length s == 1
1563+ then '0' : s
1564+ else s
1565+
1566+ asciiTab =
1567+ ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
1568+ '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
1569+ '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
1570+ '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
1571+
1572+
14201573translateDeclaration :: (String, SDecl) -> [JS]
14211574translateDeclaration (path, SFun name params stackSize body)
1422− {-| (MN _ ap) <- name-}
1423− {-, (SLet var val next) <- body-}
1424− {-, (SChkCase cvar cases) <- next-}
1425− {-, ap == txt "APPLY" =-}
1426− {-let lvar = translateVariableName var-}
1427− {-lookup t = (JSApp-}
1428− {-(JSIndex (JSIdent t) (JSProj (JSIdent lvar) "tag"))-}
1429− {-[JSIdent "fn0", JSIdent "arg0", JSIdent lvar]) in-}
1430− {-[ lookupTable "APPLY" [(var, "chk")] var cases-}
1431− {-, jsDecl $ JSFunction ["fn0", "arg0"] (-}
1432− {-JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")-}
1433− {-, JSAlloc (translateVariableName var) (-}
1434− {-Just $ translateExpression val-}
1435− {-)-}
1436− {-, JSReturn $ (JSTernary (-}
1437− {-(JSVar var `jsInstanceOf` jsCon) `jsAnd`-}
1438− {-(hasProp (idrLTNamespace ++ "APPLY") (translateVariableName var))-}
1439− {-) (lookup (idrLTNamespace ++ "APPLY")) JSNull)-}
1440− {-]-}
1441− {-)-}
1442− {-]-}
1443−
1444− {-| (MN _ ev) <- name-}
1445− {-, (SChkCase var cases) <- body-}
1446− {-, ev == txt "EVAL" =-}
1447− {-[ lookupTable "EVAL" [] var cases-}
1448− {-, jsDecl $ JSFunction ["arg0"] (JSReturn $-}
1449− {-JSTernary (-}
1450− {-(JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`-}
1451− {-(hasProp (idrLTNamespace ++ "EVAL") "arg0")-}
1452− {-) (JSApp-}
1453− {-(JSIndex (JSIdent (idrLTNamespace ++ "EVAL")) (JSProj (JSIdent "arg0") "tag"))-}
1454− {-[JSIdent "arg0"]-}
1455− {-) (JSIdent "arg0")-}
1456− {-)-}
1457− {-]-}
1575+ | (MN _ ap) <- name
1576+ , (SChkCase var cases) <- body
1577+ , ap == txt "APPLY" =
1578+ [ lookupTable "APPLY" [] var cases
1579+ , jsDecl $ JSFunction ["mfn0", "marg0"] (JSReturn $
1580+ JSTernary (
1581+ (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1582+ (hasProp (idrLTNamespace ++ "APPLY") "mfn0")
1583+ ) (JSApp
1584+ (JSIndex
1585+ (JSIdent (idrLTNamespace ++ "APPLY"))
1586+ (JSProj (JSIdent "mfn0") "tag")
1587+ )
1588+ [JSIdent "mfn0", JSIdent "marg0"]
1589+ ) JSNull
1590+ )
1591+ ]
1592+
1593+ | (MN _ ev) <- name
1594+ , (SChkCase var cases) <- body
1595+ , ev == txt "EVAL" =
1596+ [ lookupTable "EVAL" [] var cases
1597+ , jsDecl $ JSFunction ["marg0"] (JSReturn $
1598+ JSTernary (
1599+ (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1600+ (hasProp (idrLTNamespace ++ "EVAL") "marg0")
1601+ ) (JSApp
1602+ (JSIndex
1603+ (JSIdent (idrLTNamespace ++ "EVAL"))
1604+ (JSProj (JSIdent "marg0") "tag")
1605+ )
1606+ [JSIdent "marg0"]
1607+ ) (JSIdent "marg0")
1608+ )
1609+ ]
14581610 | otherwise =
14591611 let fun = translateExpression body in
14601612 [jsDecl $ jsFun fun]
@@ -1723,6 +1875,12 @@ translateExpression (SError msg) =
17231875translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
17241876 jsCall (idrRTNamespace ++ "print") [JSVar var]
17251877
1878+translateExpression (SForeign _ _ "isNull" [(FPtr, var)]) =
1879+ JSBinOp "==" (JSVar var) JSNull
1880+
1881+translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =
1882+ JSBinOp "==" (JSVar lhs) (JSVar rhs)
1883+
17261884translateExpression (SForeign _ _ fun args) =
17271885 ffi fun (map generateWrapper args)
17281886 where