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

all: added long type

Browse Source
This commit is contained in:
hellerve 2017-10-25 19:17:53 +02:00
parent a44cfbe1df
commit 3a03969717
9 changed files with 130 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
app/Main.hs
View File

@ -148,6 +148,7 @@ startingTypeEnv = Env { envBindings = Map.empty, envParent = Nothing, envModuleN
preludeModules :: String -> [String]
preludeModules carpDir = map (\s -> carpDir ++ "/core/" ++ s ++ ".carp") [ "Macros"
, "Int"
, "Long"
, "Double"
, "Float"
, "Array"

21
core/Long.carp Normal file
View File

@ -0,0 +1,21 @@
(defmodule Long
(register + (λ [Long Long] Long))
(register - (λ [Long Long] Long))
(register * (λ [Long Long] Long))
(register / (λ [Long Long] Long))
(register < (λ [Long Long] Bool))
(register > (λ [Long Long] Bool))
(register = (λ [Long Long] Bool))
(register /= (λ [Long Long] Bool))
(register mod (λ [Long Long] Long))
(register seed (λ [Long] ()))
(register random (λ [] Long))
(register random-between (λ [Long Long] Long))
(register str (λ [Long] String))
(register from-string (λ [&String] Long))
(register mask (λ [Long Long] Bool))
(register inc (λ [Long] Long))
(register dec (λ [Long] Long))
(register copy (λ [&Long] Long)) ;; TODO: Should not be needed when refs to value types are auto-converted to non-refs.
)

60
core/prelude.h
View File

@ -43,19 +43,32 @@ bool not(bool b) {
return !b;
}
int Int__PLUS_(x, y) { return x + y; }
int Int__MINUS_(x, y) { return x - y; }
int Int__MUL_(x, y) { return x * y; }
int Int__DIV_(x, y) { return x / y; }
bool Int__EQ_(x, y) { return x == y; }
bool Int__DIV__EQ_(x, y) { return x != y; }
bool Int__LT_(x, y) { return x < y; }
bool Int__GT_(x, y) { return x > y; }
int Int__PLUS_(int x, int y) { return x + y; }
int Int__MINUS_(int x, int y) { return x - y; }
int Int__MUL_(int x, int y) { return x * y; }
int Int__DIV_(int x, int y) { return x / y; }
bool Int__EQ_(int x, int y) { return x == y; }
bool Int__DIV__EQ_(int x, int y) { return x != y; }
bool Int__LT_(int x, int y) { return x < y; }
bool Int__GT_(int x, int y) { return x > y; }
int Int_inc(int x) { return x + 1; }
int Int_dec(int x) { return x - 1; }
long Long__PLUS_(long x, long y) { return x + y; }
long Long__MINUS_(long x, long y) { return x - y; }
long Long__MUL_(long x, long y) { return x * y; }
long Long__DIV_(long x, long y) { return x / y; }
bool Long__EQ_(long x, long y) { return x == y; }
bool Long__DIV__EQ_(long x, long y) { return x != y; }
bool Long__LT_(long x, long y) { return x < y; }
bool Long__GT_(long x, long y) { return x > y; }
long Long_inc(long x) { return x + 1; }
long Long_dec(long x) { return x - 1; }
int Int_copy(int *x) { return *x; }
int Long_copy(long *x) { return *x; }
float Float_copy(float *x) { return *x; }
double Double_copy(double *x) { return *x; }
@ -113,6 +126,37 @@ bool Int_mask(int a, int b) {
return a & b;
}
long Long_from_MINUS_string(string *s) {
return atol(*s);
}
long Long_mod(long x, long divider) {
return x % divider;
}
void Long_seed(long seed) {
srand(seed);
}
long Long_random() {
return rand();
}
long Long_random_MINUS_between(long lower, long upper) {
long diff = upper - lower;
return lower + (rand() % diff);
}
string Long_str(long x) {
char *buffer = CARP_MALLOC(64);
snprintf(buffer, 64, "%ldl", x);
return buffer;
}
bool Long_mask(long a, long b) {
return a & b;
}
void String_delete(string s) {
CARP_FREE(s);
}

13
src/Commands.hs
View File

@ -67,7 +67,7 @@ consumeExpr :: Context -> XObj -> ReplCommand
consumeExpr (Context globalEnv typeEnv _ _ _) xobj =
case expandAll globalEnv xobj of
Left err -> ReplMacroError (show err)
Right expanded ->
Right expanded ->
case annotate typeEnv globalEnv (setFullyQualifiedSymbols globalEnv expanded) of
Left err -> ReplTypeError (show err)
Right annXObjs -> ListOfCommands (map printC annXObjs)
@ -118,7 +118,7 @@ objToCommand ctx xobj =
XObj (Sym (SymPath _ "add-lib")) _ _ : XObj (Str flag) _ _ : [] -> AddLibraryFlag flag
XObj (Sym (SymPath _ "project")) _ _ : [] -> DisplayProject
XObj (Sym (SymPath _ "load")) _ _ : XObj (Str path) _ _ : [] -> Load path
XObj (Sym (SymPath _ "reload")) _ _ : [] -> Reload
XObj (Sym (SymPath _ "reload")) _ _ : [] -> Reload
_ -> consumeExpr ctx xobj
Sym (SymPath [] (':' : text)) -> ListOfCommands (mapMaybe charToCommand text)
_ -> consumeExpr ctx xobj
@ -252,11 +252,11 @@ executeCommand ctx@(Context env typeEnv pathStrings proj lastInput) cmd =
_ ->
do putStrLnWithColor Red ("Can't get info from non-symbol: " ++ pretty xobj)
return ctx
Type xobj ->
case xobj of
XObj (Sym path@(SymPath _ name)) _ _ ->
case lookupInEnv path env of
case lookupInEnv path env of
Just (_, binder) ->
do putStrLnWithColor White (show binder)
return ctx
@ -310,7 +310,7 @@ executeCommand ctx@(Context env typeEnv pathStrings proj lastInput) cmd =
dynamic = XObj (Lst [XObj Dynamic Nothing Nothing, XObj (Sym path) Nothing Nothing, params, body])
(info body) (Just DynamicTy)
in return (ctx { contextGlobalEnv = envInsertAt env path dynamic })
Eval xobj ->
case eval env xobj of
Left e ->
@ -328,7 +328,7 @@ executeCommand ctx@(Context env typeEnv pathStrings proj lastInput) cmd =
Right expanded ->
do putStrLnWithColor Yellow (pretty expanded)
return ctx
Use path xobj ->
let e = getEnv env pathStrings
useThese = envUseModules e
@ -499,6 +499,7 @@ executeCommand ctx@(Context env typeEnv pathStrings proj lastInput) cmd =
putStrLn ""
putStrLn "Number literals:"
putStrLn "1 Int"
putStrLn "1l Int"
putStrLn "1.0 Double"
putStrLn "1.0f Float"
putStrLn ""

17
src/Deftype.hs
View File

@ -19,15 +19,15 @@ data AllocationMode = StackAlloc | HeapAlloc
-- generated by a deftype.
moduleForDeftype :: TypeEnv -> Env -> [String] -> String -> [XObj] -> Maybe Info -> Either String (String, XObj, [XObj])
moduleForDeftype typeEnv env pathStrings typeName rest i =
let typeModuleName = typeName
let typeModuleName = typeName
emptyTypeModuleEnv = Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv
-- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'.
-- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc.
insidePath = pathStrings ++ [typeModuleName]
insidePath = pathStrings ++ [typeModuleName]
in case validateMembers typeEnv rest of
Left err ->
Left err
Right _ ->
Right _ ->
case
do okInit <- templateForInit insidePath typeName rest
okNew <- templateForNew insidePath typeName rest
@ -42,7 +42,7 @@ moduleForDeftype typeEnv env pathStrings typeName rest i =
return (typeModuleName, typeModuleXObj, deps)
of
Just x -> Right x
Nothing -> Left "Something's wrong with the templates..." -- TODO: Better messages here, should come from the template functions!
Nothing -> Left "Something's wrong with the templates..." -- TODO: Better messages here, should come from the template functions!
-- | Make sure that the member declarations in a type definition
-- | Follow the pattern [<name> <type>, <name> <type>, ...]
@ -70,6 +70,7 @@ validateMembers typeEnv rest =
IntTy -> return ()
FloatTy -> return ()
DoubleTy -> return ()
LongTy -> return ()
BoolTy -> return ()
StringTy -> return ()
CharTy -> return ()
@ -161,7 +162,7 @@ templateInit allocationMode typeName members =
, case allocationMode of
StackAlloc -> " $p instance;"
HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));"
, joinWith "\n" (map (memberAssignment allocationMode) members)
, joinWith "\n" (map (memberAssignment allocationMode) members)
, " return instance;"
, "}"]))
(const [])
@ -211,7 +212,7 @@ memberStr typeEnv env (memberName, memberTy) =
]
Nothing ->
" // Failed to find str function for " ++ memberName ++ " : " ++ show memberTy ++ "\n"
-- | Creates the C code for an arg to the init function.
-- | i.e. "(deftype A [x Int])" will generate "int x" which
-- | will be used in the init function like this: "A_init(int x)"
@ -232,7 +233,7 @@ templateGetter member fixedMemberTy =
let maybeAmpersand = case fixedMemberTy of
RefTy _ -> "&"
_ -> ""
in
in
Template
(FuncTy [RefTy (VarTy "p")] (VarTy "t"))
(const (toTemplate "$t $NAME($(Ref p) p)"))
@ -276,7 +277,7 @@ templateDelete typeEnv env members =
(FuncTy [(VarTy "p")] UnitTy)
(const (toTemplate $ "void $NAME($p p)"))
(const (toTemplate $ unlines [ "$DECL {"
, (joinWith "\n" (map (memberDeletion typeEnv env) members))
, (joinWith "\n" (map (memberDeletion typeEnv env) members))
, "}"]))
(\_ -> concatMap (depsOfPolymorphicFunction typeEnv env "delete" . typesDeleterFunctionType)
(filter (isManaged typeEnv) (map snd members)))

1
src/Emit.hs
View File

@ -55,6 +55,7 @@ toC root = emitterSrc (execState (visit 0 root) (EmitterState ""))
Lst _ -> visitList indent xobj
Arr _ -> visitArray indent xobj
Num IntTy num -> return (show ((round num) :: Int))
Num LongTy num -> return (show ((round num) :: Int) ++ "l")
Num FloatTy num -> return (show num ++ "f")
Num DoubleTy num -> return (show num)
Num _ _ -> error "Can't emit invalid number type."

38
src/Obj.hs
View File

@ -133,6 +133,7 @@ pretty root = visit 0 root
Lst lst -> "(" ++ joinWithSpace (map (visit indent) lst) ++ ")"
Arr arr -> "[" ++ joinWithSpace (map (visit indent) arr) ++ "]"
Num IntTy num -> show (round num :: Int)
Num LongTy num -> show num ++ "l"
Num FloatTy num -> show num ++ "f"
Num DoubleTy num -> show num
Num _ _ -> compilerError "Invalid number type."
@ -227,10 +228,10 @@ dependencyDepthOfTypedef _ xobj =
depthOfType :: TypeEnv -> String -> Maybe Ty -> Int
depthOfType typeEnv selfName ty = visitType ty
where
where
visitType :: Maybe Ty -> Int
visitType (Just (StructTy name _)) = depthOfStructType name
visitType (Just (FuncTy argTys retTy)) =
visitType (Just (FuncTy argTys retTy)) =
-- trace ("Depth of args of " ++ show argTys ++ ": " ++ show (map (visitType . Just) argTys))
(maximum (visitType (Just retTy) : (map (visitType . Just) argTys))) + 1
visitType (Just (PointerTy p)) = visitType (Just p)
@ -304,19 +305,19 @@ envIsExternal env =
-- | Find the Binder at a specified path.
lookupInEnv :: SymPath -> Env -> Maybe (Env, Binder)
lookupInEnv (SymPath [] name) env =
lookupInEnv (SymPath [] name) env =
case Map.lookup name (envBindings env) of
Just found -> Just (env, found)
Nothing -> case envParent env of
Just parent -> lookupInEnv (SymPath [] name) parent
Nothing -> Nothing
lookupInEnv path@(SymPath (p : ps) name) env =
lookupInEnv path@(SymPath (p : ps) name) env =
case Map.lookup p (envBindings env) of
Just (Binder xobj) ->
Just (Binder xobj) ->
case xobj of
(XObj (Mod modEnv) _ _) -> lookupInEnv (SymPath ps name) modEnv
_ -> Nothing
Nothing ->
Nothing ->
case envParent env of
Just parent -> lookupInEnv path parent
Nothing -> Nothing
@ -331,7 +332,7 @@ multiLookupALL = multiLookupInternal True
-- | The advanced version of multiLookup that allows for looking into modules that are NOT imported.
multiLookupInternal :: Bool -> String -> Env -> [(Env, Binder)]
multiLookupInternal allowLookupInAllModules name rootEnv = recursiveLookup rootEnv
where lookupInLocalEnv :: String -> Env -> Maybe (Env, Binder)
lookupInLocalEnv n localEnv = case Map.lookup n (envBindings localEnv) of -- No recurse!
Just b -> Just (localEnv, b)
@ -343,7 +344,7 @@ multiLookupInternal allowLookupInAllModules name rootEnv = recursiveLookup rootE
in envs ++ (concatMap imports envs)
-- Only lookup in imported modules:
else let envs = mapMaybe (\path -> fmap getEnvFromBinder (lookupInEnv path env)) (envUseModules env)
in envs ++ (concatMap imports envs)
in envs ++ (concatMap imports envs)
binderToEnv :: Binder -> Maybe Env
binderToEnv (Binder (XObj (Mod e) _ _)) = Just e
@ -351,9 +352,9 @@ multiLookupInternal allowLookupInAllModules name rootEnv = recursiveLookup rootE
importsLookup :: Env -> [(Env, Binder)]
importsLookup env = mapMaybe (lookupInLocalEnv name) (imports env)
recursiveLookup :: Env -> [(Env, Binder)]
recursiveLookup env =
recursiveLookup env =
let spine = case Map.lookup name (envBindings env) of
Just found -> [(env, found)]
Nothing -> []
@ -399,7 +400,7 @@ extendEnv env name xobj = envAddBinding env name (Binder xobj)
-- | Add a Binder to an environment at a specific path location.
envInsertAt :: Env -> SymPath -> XObj -> Env
envInsertAt env (SymPath [] name) xobj = envAddBinding env name (Binder xobj)
envInsertAt env (SymPath (p:ps) name) xobj =
envInsertAt env (SymPath (p:ps) name) xobj =
case Map.lookup p (envBindings env) of
Just (Binder (XObj (Mod innerEnv) i t)) ->
let newInnerEnv = Binder (XObj (Mod (envInsertAt innerEnv (SymPath ps name) xobj)) i t)
@ -409,7 +410,7 @@ envInsertAt env (SymPath (p:ps) name) xobj =
envReplaceEnvAt :: Env -> [String] -> Env -> Env
envReplaceEnvAt _ [] replacement = replacement
envReplaceEnvAt env (p:ps) replacement =
envReplaceEnvAt env (p:ps) replacement =
case Map.lookup p (envBindings env) of
Just (Binder (XObj (Mod innerEnv) i t)) ->
let newInnerEnv = Binder (XObj (Mod (envReplaceEnvAt innerEnv ps replacement)) i t)
@ -459,10 +460,10 @@ setFullyQualifiedSymbols env (XObj (Lst (defn@(XObj Defn _ _) :
in (XObj (Lst [defn, sym, args, setFullyQualifiedSymbols envWithArgs body]) i t)
setFullyQualifiedSymbols env (XObj (Lst (the@(XObj The _ _) : typeXObj : value : [])) i t) =
let value' = setFullyQualifiedSymbols env value
in (XObj (Lst [the, typeXObj, value']) i t)
in (XObj (Lst [the, typeXObj, value']) i t)
setFullyQualifiedSymbols env (XObj (Lst (def@(XObj Def _ _) : sym : expr : [])) i t) =
let expr' = setFullyQualifiedSymbols env expr
in (XObj (Lst [def, sym, expr']) i t)
in (XObj (Lst [def, sym, expr']) i t)
setFullyQualifiedSymbols env (XObj (Lst (letExpr@(XObj Let _ _) : bind@(XObj (Arr bindings) bindi bindt) : body : [])) i t) =
if even (length bindings)
then let innerEnv = Env Map.empty (Just env) (Just "LET") [] InternalEnv
@ -478,11 +479,11 @@ setFullyQualifiedSymbols env (XObj (Lst (letExpr@(XObj Let _ _) : bind@(XObj (Ar
setFullyQualifiedSymbols env (XObj (Lst xobjs) i t) =
let xobjs' = map (setFullyQualifiedSymbols env) xobjs
in XObj (Lst xobjs') i t
setFullyQualifiedSymbols env xobj@(XObj (Sym path) i t) =
setFullyQualifiedSymbols env xobj@(XObj (Sym path) i t) =
case multiLookupQualified path env of
[] -> xobj
[(_, Binder foundOne)] -> XObj (Sym (getPath foundOne)) i t
multiple ->
multiple ->
case filter (not . envIsExternal . fst) multiple of
-- There is at least one local binding, use the path of that one:
(_, Binder local) : _ -> XObj (Sym (getPath local)) i t
@ -528,7 +529,7 @@ instance Show Project where
data Includer = SystemInclude String
| LocalInclude String
deriving Eq
instance Show Includer where
show (SystemInclude file) = "<" ++ file ++ ">"
show (LocalInclude file) = "\"" ++ file ++ "\""
@ -538,6 +539,7 @@ xobjToTy :: XObj -> Maybe Ty
xobjToTy (XObj (Sym (SymPath _ "Int")) _ _) = Just IntTy
xobjToTy (XObj (Sym (SymPath _ "Float")) _ _) = Just FloatTy
xobjToTy (XObj (Sym (SymPath _ "Double")) _ _) = Just DoubleTy
xobjToTy (XObj (Sym (SymPath _ "Long")) _ _) = Just LongTy
xobjToTy (XObj (Sym (SymPath _ "String")) _ _) = Just StringTy
xobjToTy (XObj (Sym (SymPath _ "Char")) _ _) = Just CharTy
xobjToTy (XObj (Sym (SymPath _ "Bool")) _ _) = Just BoolTy
@ -650,7 +652,7 @@ defineFunctionTypeAlias aliasTy = defineTypeAlias (tyToC aliasTy) aliasTy
defineArrayTypeAlias :: Ty -> XObj
defineArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy "Array" [])
-- | Find out if a type is "external", meaning it is not defined by the user
-- | Find out if a type is "external", meaning it is not defined by the user
-- in this program but instead imported from another C library or similar.
isExternalType :: TypeEnv -> Ty -> Bool
isExternalType typeEnv (PointerTy p) =

13
src/Parsing.hs
View File

@ -64,9 +64,22 @@ integer = do i <- createInfo
then return (XObj (Sym (SymPath [] "-")) i Nothing)
else return (XObj (Num IntTy (read num)) i Nothing)
long :: Parsec.Parsec String ParseState XObj
long = do i <- createInfo
num0 <- firstDigit
num1 <- Parsec.many Parsec.digit
let num = num0 : num1
incColumn (length num)
_ <- Parsec.char 'l'
incColumn 1
if num == "-"
then return (XObj (Sym (SymPath [] "-")) i Nothing)
else return (XObj (Num LongTy (read num)) i Nothing)
number :: Parsec.Parsec String ParseState XObj
number = Parsec.try float <|>
Parsec.try double <|>
Parsec.try long <|>
Parsec.try integer
string :: Parsec.Parsec String ParseState XObj

9
src/Types.hs
View File

@ -20,6 +20,7 @@ import Util
-- | Carp types.
data Ty = IntTy
| LongTy
| BoolTy
| FloatTy
| DoubleTy
@ -41,6 +42,7 @@ instance Show Ty where
show IntTy = "Int"
show FloatTy = "Float"
show DoubleTy = "Double"
show LongTy = "Long"
show BoolTy = "Bool"
show StringTy = "String"
show CharTy = "Char"
@ -74,6 +76,7 @@ tyToCManglePtr _ IntTy = "int"
tyToCManglePtr _ BoolTy = "bool"
tyToCManglePtr _ FloatTy = "float"
tyToCManglePtr _ DoubleTy = "double"
tyToCManglePtr _ LongTy = "long"
tyToCManglePtr _ StringTy = "string"
tyToCManglePtr _ CharTy = "char"
tyToCManglePtr _ UnitTy = "void"
@ -140,7 +143,7 @@ unifySignatures v t = Map.fromList (unify v t)
unify (RefTy a) (RefTy b) = unify a b
unify a@(RefTy _) b = compilerError ("Can't unify " ++ show a ++ " with " ++ show b)
unify (FuncTy argTysA retTyA) (FuncTy argTysB retTyB) = let argToks = concat (zipWith unify argTysA argTysB)
retToks = unify retTyA retTyB
in argToks ++ retToks
@ -152,7 +155,7 @@ unifySignatures v t = Map.fromList (unify v t)
areUnifiable :: Ty -> Ty -> Bool
areUnifiable (VarTy _) (VarTy _) = True
areUnifiable (VarTy _) _ = True
areUnifiable _ (VarTy _) = True
areUnifiable _ (VarTy _) = True
areUnifiable (StructTy a aArgs) (StructTy b bArgs)
| length aArgs /= length bArgs = False
| a == b = let argBools = zipWith areUnifiable aArgs bArgs
@ -167,7 +170,7 @@ areUnifiable (FuncTy argTysA retTyA) (FuncTy argTysB retTyB)
| length argTysA /= length argTysB = False
| otherwise = let argBools = zipWith areUnifiable argTysA argTysB
retBool = areUnifiable retTyA retTyB
in all (== True) (retBool : argBools)
in all (== True) (retBool : argBools)
areUnifiable (FuncTy _ _) _ = False
areUnifiable a b | a == b = True
| otherwise = False