mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
all: added long type
This commit is contained in:
parent
a44cfbe1df
commit
3a03969717
@ -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
21
core/Long.carp
Normal 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.
|
||||
)
|
||||
|
@ -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);
|
||||
}
|
||||
|
@ -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 ""
|
||||
|
@ -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)))
|
||||
|
@ -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
38
src/Obj.hs
@ -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) =
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user