@@ -224,7 +224,7 @@ codegenJavaScript target definitions filename outputType = do
224224 ("#!/usr/bin/env node\n", "-node")
225225 JavaScript ->
226226 ("", "-browser")
227− path <- getDataDir
227+ path <- getDataDir
228228 idrRuntime <- readFile $ path ++ "/js/Runtime-common.js"
229229 tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"]
230230 writeFile filename $ intercalate "\n" $ [ header
@@ -246,19 +246,22 @@ codegenJavaScript target definitions filename outputType = do
246246 mainLoop :: String
247247 mainLoop = compileJS $
248248 JSSeq [ JSAlloc "main" $ Just $ JSFunction [] (
249− jsTailcall $ jsCall "__IDR__runMain0" []
249+ jsTailcall $ jsCall mainFun []
250250 )
251251 , jsCall "main" []
252252 ]
253253
254+ mainFun :: String
255+ mainFun = idrNamespace ++ translateName (MN 0 "runMain")
256+
254257translateIdentifier :: String -> String
255258translateIdentifier =
256259 replaceReserved . concatMap replaceBadChars
257260 where replaceBadChars :: Char -> String
258261 replaceBadChars c
259− | ' ' <- c = "_"
260− | '_' <- c = "__"
261− | isDigit c = "_" ++ [c] ++ "_"
262+ | ' ' <- c = "_"
263+ | '_' <- c = "__"
264+ | isDigit c = '_' : show (ord c)
262265 | not (isLetter c && isAscii c) = '_' : show (ord c)
263266 | otherwise = [c]
264267 replaceReserved s
@@ -317,19 +320,24 @@ translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
317320translateNamespace NErased = idrNamespace
318321
319322translateName :: Name -> String
320−translateName (UN name) = translateIdentifier name
321−translateName (NS name _) = translateName name
322−translateName (MN i name) = translateIdentifier name ++ show i
323−translateName (SN name) = translateSpecialName name
324−translateName NErased = ""
323+translateName (UN name) = 'u' : translateIdentifier name
324+translateName (NS name _) = 'n' : translateName name
325+translateName (MN i name) = 'm' : translateIdentifier name ++ show i
326+translateName (SN name) = 's' : translateSpecialName name
327+translateName NErased = "e"
325328
326329translateSpecialName :: SpecialName -> String
327330translateSpecialName name
328− | WhereN i m n <- name = translateName m ++ translateName n ++ show i
329− | InstanceN n s <- name = translateName n ++ concatMap translateIdentifier s
330− | ParentN n s <- name = translateName n ++ translateIdentifier s
331− | MethodN n <- name = translateName n
332− | CaseN n <- name = translateName n
331+ | WhereN i m n <- name =
332+ 'w' : translateName m ++ translateName n ++ show i
333+ | InstanceN n s <- name =
334+ 'i' : translateName n ++ concatMap translateIdentifier s
335+ | ParentN n s <- name =
336+ 'p' : translateName n ++ translateIdentifier s
337+ | MethodN n <- name =
338+ 'm' : translateName n
339+ | CaseN n <- name =
340+ 'c' : translateName n
333341
334342translateConstant :: Const -> JS
335343translateConstant (I i) = JSNum (JSInt i)
@@ -436,7 +444,8 @@ translateDeclaration (path, SFun name params stackSize body)
436444 assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
437445
438446 assignAux :: (LVar, String) -> JS
439− assignAux (var, val) = JSAssign (JSRaw $ translateVariableName var) (JSRaw val)
447+ assignAux (var, val) =
448+ JSAssign (JSRaw $ translateVariableName var) (JSRaw val)
440449
441450 p :: [String]
442451 p = map translateName params
@@ -626,59 +635,9 @@ translateExpression (SError msg) =
626635translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
627636 jsCall (idrRTNamespace ++ "print") [JSVar var]
628637
629−translateExpression (SForeign _ _ fun args)
630− | "[]=" `isSuffixOf` fun
631− , (obj:idx:val:[]) <- args =
632− JSRaw $ concat [object obj, index idx, assign val]
633−
634− | "[]" `isSuffixOf` fun
635− , (obj:idx:[]) <- args =
636− JSRaw $ object obj ++ index idx
637−
638− | "[" `isPrefixOf` fun && "]=" `isSuffixOf` fun
639− , (obj:val:[]) <- args =
640− JSRaw $ concat [object obj, '[' : name ++ "]", assign val]
641−
642− | "[" `isPrefixOf` fun && "]" `isSuffixOf` fun
643− , (obj:[]) <- args =
644− JSRaw $ object obj ++ '[' : name ++ "]"
645−
646− | "." `isPrefixOf` fun, "=" `isSuffixOf` fun
647− , (obj:val:[]) <- args =
648− JSRaw $ concat [object obj, field, assign val]
649−
650− | "." `isPrefixOf` fun
651− , (obj:[]) <- args =
652− JSRaw $ object obj ++ field
653−
654− | "." `isPrefixOf` fun
655− , (obj:[(FUnit, _)]) <- args =
656− JSRaw $ concat [object obj, method, "()"]
657−
658− | "." `isPrefixOf` fun
659− , (obj:as) <- args =
660− JSRaw $ concat [object obj, method, arguments as]
661−
662− | "[]=" `isSuffixOf` fun
663− , (idx:val:[]) <- args =
664− JSRaw $ concat [array, index idx, assign val]
665−
666− | "[]" `isSuffixOf` fun
667− , (idx:[]) <- args =
668− JSRaw $ array ++ index idx
669−
670− | otherwise = JSRaw $ fun ++ arguments args
638+translateExpression (SForeign _ _ fun args) =
639+ ffi fun (map generateWrapper args)
671640 where
672− name = filter (`notElem` "[]=") fun
673− method = name
674− field = name
675− array = name
676− object o = translateVariableName (snd o)
677− index i = "[" ++ translateVariableName (snd i) ++ "]"
678− assign v = '=' : generateWrapper v
679− arguments as =
680− '(' : intercalate "," (map generateWrapper as) ++ ")"
681−
682641 generateWrapper (ffunc, name)
683642 | FFunction <- ffunc =
684643 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
@@ -727,6 +686,37 @@ translateExpression SNothing = JSNull
727686translateExpression e =
728687 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
729688
689+data FFI = FFICode Char | FFIArg Int | FFIError String
690+
691+ffi :: String -> [String] -> JS
692+ffi code args = let parsed = ffiParse code in
693+ case ffiError parsed of
694+ Just err -> JSError err
695+ Nothing -> JSRaw $ renderFFI parsed args
696+ where
697+ ffiParse :: String -> [FFI]
698+ ffiParse "" = []
699+ ffiParse ['%'] = [FFIError "Invalid positional argument"]
700+ ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
701+ ffiParse ('%':s:ss)
702+ | isDigit s =
703+ FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
704+ | otherwise =
705+ [FFIError "Invalid positional argument"]
706+ ffiParse (s:ss) = FFICode s : ffiParse ss
707+
708+ ffiError :: [FFI] -> Maybe String
709+ ffiError [] = Nothing
710+ ffiError ((FFIError s):xs) = Just s
711+ ffiError (x:xs) = ffiError xs
712+
713+ renderFFI :: [FFI] -> [String] -> String
714+ renderFFI [] _ = ""
715+ renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
716+ renderFFI ((FFIArg i) : fs) args
717+ | i < length args && i >= 0 = args !! i ++ renderFFI fs args
718+ | otherwise = "Argument index out of bounds"
719+
730720data CaseType = ConCase Int
731721 | TypeCase JSType
732722 | DefaultCase