mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 13:37:57 +03:00
Calling works.
This commit is contained in:
parent
2bf5695324
commit
65ade0848f
@ -33,4 +33,8 @@ bool not(bool b) {
|
||||
bool and(bool x, bool y) { return x && y; }
|
||||
bool or(bool x, bool y) { return x || y; }
|
||||
|
||||
void System_signal2(void *f) {
|
||||
|
||||
}
|
||||
|
||||
#endif
|
||||
|
@ -30,7 +30,7 @@
|
||||
(Int.+ 1 (f 5)))
|
||||
|
||||
(defn main [x]
|
||||
(map blaha [inc dec (fn [_] x)]))
|
||||
(Array.endo-map blaha [inc dec (fn [_] x)]))
|
||||
|
||||
;; /* void blaha(void *f) { */
|
||||
;; /* int _0; */
|
||||
|
@ -83,7 +83,11 @@
|
||||
(defn on-abort [x]
|
||||
(println* "Abort!"))
|
||||
|
||||
(defmodule System
|
||||
(register signal2 (Fn [Int (Fn [Int] ())] ())))
|
||||
|
||||
(defn main []
|
||||
(do
|
||||
(System.signal System.signal-abort on-abort)
|
||||
;;(System.signal System.signal-abort on-abort)
|
||||
(System.signal2 System.signal-abort on-abort)
|
||||
0))
|
||||
|
52
src/Emit.hs
52
src/Emit.hs
@ -400,25 +400,9 @@ toC toCMode root = emitterSrc (execState (visit startingIndent root) (EmitterSta
|
||||
appendToSrc (addIndent indent ++ "break;\n")
|
||||
return ""
|
||||
|
||||
-- Function application
|
||||
|
||||
-- func@(XObj (Sym _ (LookupGlobal ExternalCode)) _ _) : args ->
|
||||
-- do funcToCall <- visit indent func
|
||||
-- argListAsC <- createArgList indent args
|
||||
-- let funcTy = case ty func of
|
||||
-- Just actualType -> actualType
|
||||
-- _ -> error ("No type on func " ++ show func)
|
||||
-- FuncTy argTys retTy = funcTy
|
||||
-- callFunction = funcToCall ++ "(" ++ argListAsC ++ ");\n"
|
||||
-- if retTy == UnitTy
|
||||
-- then do appendToSrc (addIndent indent ++ callFunction)
|
||||
-- return ""
|
||||
-- else do let varName = freshVar i
|
||||
-- appendToSrc (addIndent indent ++ tyToCLambdaFix retTy ++ " " ++ varName ++ " = " ++ callFunction)
|
||||
-- return varName
|
||||
|
||||
-- Function application (functions with overridden names)
|
||||
func@(XObj (Sym _ (LookupGlobalOverride overriddenName)) _ _) : args ->
|
||||
do argListAsC <- createArgList indent args
|
||||
do argListAsC <- createArgList indent True args -- The 'True' means "unwrap lambdas" which is always the case for functions with overriden names (they are external)
|
||||
let funcTy = case ty func of
|
||||
Just actualType -> actualType
|
||||
_ -> error ("No type on func " ++ show func)
|
||||
@ -431,15 +415,25 @@ toC toCMode root = emitterSrc (execState (visit startingIndent root) (EmitterSta
|
||||
appendToSrc (addIndent indent ++ tyToCLambdaFix retTy ++ " " ++ varName ++ " = " ++ callFunction)
|
||||
return varName
|
||||
|
||||
-- Function application (normal)
|
||||
func : args ->
|
||||
do funcToCall <- visit indent func
|
||||
argListAsC <- createArgList indent args
|
||||
let unwrapLambdas = case func of
|
||||
XObj (Sym _ (LookupGlobal ExternalCode)) _ _ -> True
|
||||
_ -> False
|
||||
argListAsC <- createArgList indent unwrapLambdas args
|
||||
let funcTy = case ty func of
|
||||
Just actualType -> actualType
|
||||
_ -> error ("No type on func " ++ show func)
|
||||
FuncTy argTys retTy = funcTy
|
||||
castToFn = tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCLambdaFix argTys) ++ ")"
|
||||
castToFnWithEnv = tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCLambdaFix (StructTy "LambdaEnv" [] : argTys)) ++ ")"
|
||||
castToFn =
|
||||
if unwrapLambdas
|
||||
then tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCRawFunctionPtrFix argTys) ++ ")"
|
||||
else tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCLambdaFix argTys) ++ ")"
|
||||
castToFnWithEnv =
|
||||
if unwrapLambdas
|
||||
then tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCRawFunctionPtrFix (StructTy "LambdaEnv" [] : argTys)) ++ ")"
|
||||
else tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCLambdaFix (StructTy "LambdaEnv" [] : argTys)) ++ ")"
|
||||
callLambda = funcToCall ++ ".env ? ((" ++ castToFnWithEnv ++ ")" ++ funcToCall ++ ".callback)" ++ "(" ++ funcToCall ++ ".env" ++ (if null args then "" else ", ") ++ argListAsC ++ ") : ((" ++ castToFn ++ ")" ++ funcToCall ++ ".callback)(" ++ argListAsC ++ "); // Return type of call: " ++ show funcTy ++ "\n"
|
||||
if retTy == UnitTy
|
||||
then do appendToSrc (addIndent indent ++ callLambda)
|
||||
@ -456,9 +450,19 @@ toC toCMode root = emitterSrc (execState (visit startingIndent root) (EmitterSta
|
||||
visitList _ xobj@(XObj (Lst _) Nothing (Just _)) = error ("List is missing info! " ++ show xobj)
|
||||
visitList _ xobj = error ("Must visit list! " ++ show xobj)
|
||||
|
||||
createArgList :: Int -> [XObj] -> State EmitterState String
|
||||
createArgList indent args = do argStrings <- mapM (visit indent) args
|
||||
return (intercalate ", " argStrings)
|
||||
createArgList :: Int -> Bool -> [XObj] -> State EmitterState String
|
||||
createArgList indent unwrapLambdas args =
|
||||
do argStrings <- mapM (visit indent) args
|
||||
let argTypes = map forceTy args
|
||||
return $ intercalate ", " $ if unwrapLambdas
|
||||
then zipWith unwrapLambda argStrings argTypes
|
||||
else argStrings
|
||||
|
||||
unwrapLambda :: String -> Ty -> String
|
||||
unwrapLambda variableName ty =
|
||||
if isFunctionType ty
|
||||
then variableName ++ ".callback"
|
||||
else variableName
|
||||
|
||||
visitArray :: Int -> XObj -> State EmitterState String
|
||||
visitArray indent (XObj (Arr xobjs) (Just i) t) =
|
||||
|
@ -233,7 +233,7 @@ pretty = visit 0
|
||||
Str str -> show str
|
||||
Pattern str -> '#' : show str
|
||||
Chr c -> '\\' : c : ""
|
||||
Sym path lookup -> show path ++ " " ++ show lookup
|
||||
Sym path _ -> show path
|
||||
MultiSym originalName paths -> originalName ++ "{" ++ joinWithComma (map show paths) ++ "}"
|
||||
InterfaceSym name -> name
|
||||
Bol b -> if b then "true" else "false"
|
||||
|
@ -3,6 +3,7 @@ module Types ( TypeMappings
|
||||
, showMaybeTy
|
||||
, tyToC
|
||||
, tyToCLambdaFix
|
||||
, tyToCRawFunctionPtrFix
|
||||
, isTypeGeneric
|
||||
, SymPath(..)
|
||||
, unifySignatures
|
||||
@ -89,6 +90,10 @@ tyToCLambdaFix :: Ty -> String
|
||||
tyToCLambdaFix t@(FuncTy _ _) = "Lambda"
|
||||
tyToCLambdaFix t = tyToCManglePtr False t
|
||||
|
||||
tyToCRawFunctionPtrFix :: Ty -> String
|
||||
tyToCRawFunctionPtrFix t@(FuncTy _ _) = "void*"
|
||||
tyToCRawFunctionPtrFix t = tyToCManglePtr False t
|
||||
|
||||
tyToCManglePtr :: Bool -> Ty -> String
|
||||
tyToCManglePtr _ IntTy = "int"
|
||||
tyToCManglePtr _ BoolTy = "bool"
|
||||
|
Loading…
Reference in New Issue
Block a user