carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-11 13:37:57 +03:00
Code Issues Projects Releases Wiki Activity

Calling works.

Browse Source
This commit is contained in:
Erik Svedäng 2018-08-24 15:20:05 +02:00
parent 2bf5695324
commit 65ade0848f
6 changed files with 44 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/core.h
View File

@ -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

2
examples/lambdas.carp
View File

@ -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; */

6
examples/temp.carp
View File

@ -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
View File

@ -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) =

2
src/Obj.hs
View File

@ -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"

5
src/Types.hs
View File

@ -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"