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

Things are not working but at least some progress.

Browse Source
This commit is contained in:
Erik Svedäng 2018-06-18 17:22:20 +02:00
parent a6800e9538
commit 1749584a89
4 changed files with 51 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
core/core.h
View File

@ -15,6 +15,15 @@ typedef struct {
void *data;
} Array;
// Lambdas
typedef struct {
void *callback;
void *env;
void (*delete)(void*);
} Lambda;
typedef void* LambdaEnv
bool not(bool b) {
return !b;
}

4
examples/closures.c
View File

@ -56,11 +56,11 @@ int main() {
.delete = NULL
};
// call f
int _1 = f.env == NULL ? ((Fn_Int_Int)f.callback)(210) : ((Fn_CallClosure__Int_Int)f.callback)(f.env, 210);
int _1 = f.env ? ((Fn_CallClosure__Int_Int)f.callback)(f.env, 210) : ((Fn_Int_Int)f.callback)(210);
// delete f
if(f.delete) { f.delete(f.env); }
// call g
int _2 = g.env == NULL ? ((Fn_Int_Int)g.callback)(3) : ((Fn_CallClosure__Int_Int)g.callback)(f.env, 3);
int _2 = g.env ? ((Fn_CallClosure__Int_Int)g.callback)(f.env, 3) : ((Fn_Int_Int)g.callback)(3);
// delete g
if(g.delete) { f.delete(f.env); }
printf("_1 = %d\n_2 = %d\n", _1, _2);

53
src/Emit.hs
View File

@ -90,7 +90,7 @@ toC toCMode root = emitterSrc (execState (visit startingIndent root) (EmitterSta
'\t' -> "'\\t'"
'\n' -> "'\\n'"
x -> ['\'', x, '\'']
Sym _ _ -> visitSymbol xobj
Sym _ _ -> visitSymbol indent xobj
Defn -> error (show (DontVisitObj Defn))
Def -> error (show (DontVisitObj Def))
Let -> error (show (DontVisitObj Let))
@ -136,16 +136,22 @@ toC toCMode root = emitterSrc (execState (visit startingIndent root) (EmitterSta
escapeString ('\"':xs) = "\\\"" ++ escapeString xs
escapeString (x:xs) = x : escapeString xs
visitSymbol :: XObj -> State EmitterState String
visitSymbol xobj@(XObj (Sym _ (LookupGlobalOverride overrideWithName)) _ t) =
visitSymbol :: Int -> XObj -> State EmitterState String
visitSymbol _ xobj@(XObj (Sym _ (LookupGlobalOverride overrideWithName)) _ t) =
return overrideWithName
visitSymbol xobj@(XObj (Sym path _) _ t) =
visitSymbol indent xobj@(XObj (Sym path lookupMode) (Just i) t) =
let Just t' = t
in if isTypeGeneric t'
then error ("Can't emit symbol of generic type: " ++
show path ++ " : " ++ show t' ++ " at " ++ prettyInfoFromXObj xobj)
else return (pathToC path)
visitSymbol _ = error "Not a symbol."
else if isFunctionType t' -- && lookupMode == LookupLocal
then do let var = freshVar i
appendToSrc (addIndent indent ++ "Lambda " ++ var ++ " = { .callback = " ++ pathToC path ++ ", .env = NULL, .delete = NULL }; //" ++ show lookupMode ++ "\n")
return var
else return (pathToC path)
visitSymbol _ xobj@(XObj (Sym path _) Nothing _) = error ("Symbol missing info: " ++ show xobj)
visitSymbol _ _ = error "Not a symbol."
visitList :: Int -> XObj -> State EmitterState String
visitList indent (XObj (Lst xobjs) (Just i) t) =
@ -171,6 +177,13 @@ toC toCMode root = emitterSrc (execState (visit startingIndent root) (EmitterSta
appendToSrc "}\n\n"
return ""
-- Defn
[XObj Fn _ _, XObj (Arr argList) _ _, body] ->
do let Just (FuncTy _ retTy) = t
retVar = freshVar i
appendToSrc (addIndent indent ++ "Lambda " ++ retVar ++ " = { };\n")
return retVar
-- Def
[XObj Def _ _, XObj (Sym path _) _ _, expr] ->
case toCMode of
@ -192,13 +205,13 @@ toC toCMode root = emitterSrc (execState (visit startingIndent root) (EmitterSta
isNotVoid = bodyTy /= UnitTy
letBodyRet = freshVar i
when isNotVoid $ -- Must be declared outside the scope
appendToSrc (addIndent indent ++ tyToC bodyTy ++ " " ++ letBodyRet ++ ";\n")
appendToSrc (addIndent indent ++ tyToCLambdaFix bodyTy ++ " " ++ letBodyRet ++ ";\n")
appendToSrc (addIndent indent ++ "/* let */ {\n")
let letBindingToC (XObj (Sym (SymPath _ symName) _) _ _) expr =
do ret <- visit indent' expr
let Just bindingTy = ty expr
when (bindingTy /= UnitTy) $
appendToSrc (addIndent indent' ++ tyToC bindingTy ++ " " ++ mangle symName ++ " = " ++ ret ++ ";\n")
appendToSrc (addIndent indent' ++ tyToCLambdaFix bindingTy ++ " " ++ mangle symName ++ " = " ++ ret ++ ";\n")
letBindingToC _ _ = error "Invalid binding."
_ <- mapM (uncurry letBindingToC) (pairwise bindings)
ret <- visit indent' body
@ -215,7 +228,7 @@ toC toCMode root = emitterSrc (execState (visit startingIndent root) (EmitterSta
ifRetVar = freshVar i
when isNotVoid $
let Just ifT = ty ifTrue
in appendToSrc (addIndent indent ++ tyToC ifT ++ " " ++ ifRetVar ++ ";\n")
in appendToSrc (addIndent indent ++ tyToCLambdaFix ifT ++ " " ++ ifRetVar ++ ";\n")
exprVar <- visit indent expr
appendToSrc (addIndent indent ++ "if (" ++ exprVar ++ ") {\n")
trueVar <- visit indent' ifTrue
@ -267,7 +280,7 @@ toC toCMode root = emitterSrc (execState (visit startingIndent root) (EmitterSta
conditionVar = freshVar i
Just exprInfo = info expr
in do exprRetVar <- visitWhileExpression indent
appendToSrc (addIndent indent ++ tyToC exprTy ++ " " ++ conditionVar ++ " = " ++ exprRetVar ++ ";\n")
appendToSrc (addIndent indent ++ tyToCLambdaFix exprTy ++ " " ++ conditionVar ++ " = " ++ exprRetVar ++ ";\n")
delete indent exprInfo
appendToSrc (addIndent indent ++ "while (" ++ conditionVar ++ ") {\n")
_ <- visit indent' body
@ -296,7 +309,7 @@ toC toCMode root = emitterSrc (execState (visit startingIndent root) (EmitterSta
then do _ <- visit indent lastExpr
return ""
else do lastRet <- visit indent lastExpr
appendToSrc (addIndent indent ++ tyToC lastTy ++ " " ++ retVar ++ " = " ++ lastRet ++ ";\n")
appendToSrc (addIndent indent ++ tyToCLambdaFix lastTy ++ " " ++ retVar ++ " = " ++ lastRet ++ ";\n")
return retVar
-- Address
@ -391,14 +404,18 @@ toC toCMode root = emitterSrc (execState (visit startingIndent root) (EmitterSta
func : args ->
do funcToCall <- visit indent func
argListAsC <- createArgList indent args
let retTy = case ty func of
Just (FuncTy _ retTy) -> retTy
let funcTy = case ty func of
Just actualType -> actualType
_ -> error ("No type on func " ++ show func)
FuncTy argTys retTy = funcTy
castToFn = tyToC retTy ++ "(*)(" ++ joinWithComma (map tyToC argTys) ++ ")"
castToFnWithEnv = tyToC retTy ++ "(*)(" ++ joinWithComma (map tyToC (StructTy "LambdaEnv" [] : argTys)) ++ ")"
callLambda = funcToCall ++ ".env ? ((" ++ castToFnWithEnv ++ ")" ++ funcToCall ++ ".callback)" ++ "(" ++ funcToCall ++ ".env" ++ (if null args then "" else ", ") ++ argListAsC ++ ") : ((" ++ castToFn ++ ")" ++ funcToCall ++ ".callback)(" ++ argListAsC ++ ");\n"
if retTy == UnitTy
then do appendToSrc (addIndent indent ++ funcToCall ++ "(" ++ argListAsC ++ ");\n")
then do appendToSrc (addIndent indent ++ callLambda)
return ""
else do let varName = freshVar i
appendToSrc (addIndent indent ++ tyToC retTy ++ " " ++ varName ++ " = " ++ funcToCall ++ "(" ++ argListAsC ++ ");\n")
appendToSrc (addIndent indent ++ tyToC retTy ++ " " ++ varName ++ " = " ++ callLambda)
return varName
-- Empty list
@ -421,7 +438,7 @@ toC toCMode root = emitterSrc (execState (visit startingIndent root) (EmitterSta
appendToSrc (addIndent indent ++ "Array " ++ arrayVar ++
" = { .len = " ++ show len ++ "," ++
" .capacity = " ++ show len ++ "," ++
" .data = CARP_MALLOC(sizeof(" ++ tyToC innerTy ++ ") * " ++ show len ++ ") };\n")
" .data = CARP_MALLOC(sizeof(" ++ tyToCLambdaFix innerTy ++ ") * " ++ show len ++ ") };\n")
zipWithM_ (visitArrayElement indent arrayVar innerTy) [0..] xobjs
return arrayVar
@ -430,7 +447,7 @@ toC toCMode root = emitterSrc (execState (visit startingIndent root) (EmitterSta
visitArrayElement :: Int -> String -> Ty -> Int -> XObj -> State EmitterState ()
visitArrayElement indent arrayVar innerTy index xobj =
do visited <- visit indent xobj
appendToSrc (addIndent indent ++ "((" ++ tyToC innerTy ++ "*)" ++ arrayVar ++
appendToSrc (addIndent indent ++ "((" ++ tyToCLambdaFix innerTy ++ "*)" ++ arrayVar ++
".data)[" ++ show index ++ "] = " ++ visited ++ ";\n")
return ()
@ -534,7 +551,7 @@ toDeclaration _ = error "Missing case."
paramListToC :: [XObj] -> String
paramListToC xobjs = intercalate ", " (map getParam xobjs)
where getParam :: XObj -> String
getParam (XObj (Sym (SymPath _ name) _) _ (Just t)) = tyToC t ++ " " ++ mangle name
getParam (XObj (Sym (SymPath _ name) _) _ (Just t)) = tyToCLambdaFix t ++ " " ++ mangle name
getParam invalid = error (show (InvalidParameter invalid))
projectIncludesToC :: Project -> String

5
src/Types.hs
View File

@ -2,6 +2,7 @@ module Types ( TypeMappings
, Ty(..)
, showMaybeTy
, tyToC
, tyToCLambdaFix
, isTypeGeneric
, SymPath(..)
, unifySignatures
@ -83,6 +84,10 @@ showMaybeTy Nothing = "(missing-type)"
tyToC :: Ty -> String
tyToC = tyToCManglePtr False
tyToCLambdaFix :: Ty -> String
tyToCLambdaFix t@(FuncTy _ _) = "Lambda"
tyToCLambdaFix t = tyToCManglePtr False t
tyToCManglePtr :: Bool -> Ty -> String
tyToCManglePtr _ IntTy = "int"
tyToCManglePtr _ BoolTy = "bool"