git.iko.soy/Idris-dev
on master help sign in
javascript: first HOF FFI attempt
e725b8araichoo
jsrts/Runtime-common.js+24
compare with master
unifiedsplit
@@ -49,6 +49,30 @@ var i$CALL = function(fun,args) {
49 i$callstack.push(fun);
49 i$callstack.push(fun);
50}
50}
51
51
52+var i$ffiWrap = function(fid,oldbase,myoldbase) {
53+ return function() {
54+ i$callstack = [];
55+
56+ i$valstack_top += arguments.length;
57+ i$valstack[i$valstack_top] = fid
58+ for (var i = 1; i <= arguments.length; ++i)
59+ i$valstack[i$valstack_top + i] = arguments[i - 1];
60+ i$SLIDE(arguments.length + 1);
61+
62+ fid.app(oldbase,myoldbase);
63+
64+ while (i$callstack.length) {
65+ var func = i$callstack.pop();
66+ var args = i$callstack.pop();
67+ func.apply(this,args);
68+ }
69+
70+ i$callstack = i$vm.callstack;
71+
72+ return i$ret;
73+ }
74+}
75+
52var i$charCode = function(str) {
76var i$charCode = function(str) {
53 if (typeof str == "string")
77 if (typeof str == "string")
54 return str.charCodeAt(0);
78 return str.charCodeAt(0);
src/IRTS/CodegenJavaScript.hs+55−2
@@ -132,6 +132,37 @@ data JS = JSRaw String
132
132
133data FFI = FFICode Char | FFIArg Int | FFIError String
133data FFI = FFICode Char | FFIArg Int | FFIError String
134
134
135+ffi :: String -> [String] -> String
136+ffi code args = let parsed = ffiParse code in
137+ case ffiError parsed of
138+ Just err -> error err
139+ Nothing -> renderFFI parsed args
140+ where
141+ ffiParse :: String -> [FFI]
142+ ffiParse "" = []
143+ ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]
144+ ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
145+ ffiParse ('%':s:ss)
146+ | isDigit s =
147+ FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
148+ | otherwise =
149+ [FFIError $ "FFI - Invalid positional argument"]
150+ ffiParse (s:ss) = FFICode s : ffiParse ss
151+
152+
153+ ffiError :: [FFI] -> Maybe String
154+ ffiError [] = Nothing
155+ ffiError ((FFIError s):xs) = Just s
156+ ffiError (x:xs) = ffiError xs
157+
158+
159+ renderFFI :: [FFI] -> [String] -> String
160+ renderFFI [] _ = ""
161+ renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
162+ renderFFI ((FFIArg i) : fs) args
163+ | i < length args && i >= 0 = args !! i ++ renderFFI fs args
164+ | otherwise = error "FFI - Argument index out of bounds"
165+
135compileJS :: JS -> String
166compileJS :: JS -> String
136compileJS = compileJS' 0
167compileJS = compileJS' 0
137
168
@@ -141,8 +172,8 @@ compileJS' indent JSNoop = ""
141compileJS' indent (JSAnnotation annotation js) =
172compileJS' indent (JSAnnotation annotation js) =
142 "/** @" ++ show annotation ++ " */\n" ++ compileJS' indent js
173 "/** @" ++ show annotation ++ " */\n" ++ compileJS' indent js
143
174
144−{-compileJS' indent (JSFFI raw args) =-}
175+compileJS' indent (JSFFI raw args) =
145− {-ffi raw (map compileJS' indent args)-}
176+ ffi raw (map (compileJS' indent) args)
146
177
147compileJS' indent (JSRaw code) =
178compileJS' indent (JSRaw code) =
148 code
179 code
@@ -601,6 +632,28 @@ jsFOREIGN _ reg n args
601 ) (
632 ) (
602 JSBinOp "==" (translateReg lhs) (translateReg rhs)
633 JSBinOp "==" (translateReg lhs) (translateReg rhs)
603 )
634 )
635+ | otherwise =
636+ JSAssign (
637+ translateReg reg
638+ ) (
639+ JSFFI n (map generateWrapper args)
640+ )
641+ where
642+ generateWrapper :: (FType, Reg) -> JS
643+ generateWrapper (ty, reg)
644+ | FFunction <- ty =
645+ JSApp (JSIdent "i$ffiWrap") [ translateReg reg
646+ , JSIdent "oldbase"
647+ , JSIdent "myoldbase"
648+ ]
649+ | FFunctionIO <- ty =
650+ JSApp (JSIdent "i$ffiWrap") [ translateReg reg
651+ , JSIdent "oldbase"
652+ , JSIdent "myoldbase"
653+ ]
654+
655+ generateWrapper (_, reg) =
656+ translateReg reg
604
657
605jsREBASE :: CompileInfo -> JS
658jsREBASE :: CompileInfo -> JS
606jsREBASE _ = JSAssign jsSTACKBASE jsOLDBASE
659jsREBASE _ = JSAssign jsSTACKBASE jsOLDBASE