@@ -318,19 +318,26 @@ bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
318318bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
319319bcc i STOREOLD = indent i ++ "STOREOLD;\n"
320320bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"
321−bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "_idris_get_wrapper"
321+bcc i (FOREIGNCALL l rty (FStr fn@('&':name)) [])
322+ = indent i ++
323+ c_irts (toFType rty) (creg l ++ " = ") fn ++ ";\n"
324+bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%wrapper"
322325 = indent i ++
323326 c_irts (toFType rty) (creg l ++ " = ")
324− (fn ++ "(" ++ creg (snd x) ++ ")") ++ ";\n"
327+ ("_idris_get_wrapper(" ++ creg (snd x) ++ ")") ++ ";\n"
328+bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%dynamic"
329+ = indent i ++ c_irts (toFType rty) (creg l ++ " = ")
330+ ("(*(" ++ cFnSig "" rty xs ++ ") GETPTR(" ++ creg (snd x) ++ "))" ++
331+ "(" ++ showSep "," (map fcall xs) ++ ")") ++ ";\n"
325332bcc i (FOREIGNCALL l rty (FStr fn) args)
326333 = indent i ++
327334 c_irts (toFType rty) (creg l ++ " = ")
328335 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
329− where fcall (t, arg) = irts_c (toFType t) (creg arg)
330336bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed
331337bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"
332338-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"
333339
340+fcall (t, arg) = irts_c (toFType t) (creg arg)
334341-- Deconstruct the Foreign type in the defunctionalised expression and build
335342-- a foreign type description for c_irts and irts_c
336343toAType (FCon i)
@@ -388,6 +395,10 @@ irts_c FAny x = x
388395irts_c FFunctionIO x = wrapped x
389396irts_c FFunction x = wrapped x
390397
398+cFnSig name rty [] = ctype rty ++ " (*" ++ name ++ ")(void) "
399+cFnSig name rty args = ctype rty ++ " (*" ++ name ++ ")("
400+ ++ showSep "," (map (ctype . fst) args) ++ ") "
401+
391402wrapped x = "_idris_get_wrapper(" ++ x ++ ")"
392403
393404bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"
@@ -632,6 +643,12 @@ doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek64"
632643 = v ++ "idris_peekB64(vm," ++ creg p ++ "," ++ creg o ++")"
633644doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke64"
634645 = v ++ "idris_pokeB64(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
646+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekPtr"
647+ = v ++ "idris_peekPtr(vm," ++ creg p ++ "," ++ creg o ++")"
648+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokePtr"
649+ = v ++ "idris_pokePtr(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
650+doOp v (LExternal pk) [] | pk == sUN "prim__sizeofPtr"
651+ = v ++ "MKINT(sizeof(void*))"
635652doOp v (LExternal mpt) [p] | mpt == sUN "prim__asPtr" = v ++ "MKPTR(vm, GETMPTR("++ creg p ++"))"
636653doOp _ op args = error $ "doOp not implemented (" ++ show (op, args) ++ ")"
637654
@@ -786,8 +803,8 @@ genWrapper (desc, tag) = ret ++ " " ++ wrapperName tag ++ "(" ++
786803 indent 1 ++ "CALL(_idris__123_APPLY0_125_);\n" ++
787804 if ret /= "void"
788805 then indent 1 ++ "ret = " ++ irts_c (toFType ft) "RVAL" ++ ";\n"
789− ++ indent 1 ++ "return ret;\n}"
790− else "}\n"
806+ ++ indent 1 ++ "return ret;\n}\n\n"
807+ else "}\n\n"
791808 where
792809 (ret, ft) = rty desc
793810 argList = zip (args desc) [0..]