diff options
| -rw-r--r-- | elab.sml | 93 | ||||
| -rw-r--r-- | parser.sml | 24 | ||||
| -rw-r--r-- | syntax.sml | 6 | ||||
| -rw-r--r-- | tests/20-structure.sml | 5 | ||||
| -rw-r--r-- | tests/21-struct-datatype.sml | 6 |
5 files changed, 109 insertions, 25 deletions
@@ -35,34 +35,47 @@ struct NONE => [] | SOME (heads, tails) => heads :: transpose tails - type env = int StringMap.map * (int * int) StringMap.map + datatype env = Env of { vars: int StringMap.map, types: (int * int) StringMap.map, structTypes: env StringMap.map } - fun bindVar (name : string) (sym : int) ((vars, types) : env) : env = (StringMap.insert name sym vars, types) + val emptyEnv = Env { vars = StringMap.empty, types = StringMap.empty, structTypes = StringMap.empty } - fun lookupVar (name : string) ((vars, _) : env) : int = - case StringMap.lookup name vars of + fun bindVar (name : string) (sym : int) (Env env) : env = Env { vars = StringMap.insert name sym (#vars env), types = #types env, structTypes = #structTypes env } + + fun lookupVar (name : string) (Env env) : int = + case StringMap.lookup name (#vars env) of SOME x => x | NONE => raise Fail ("unbound identifier " ^ name) - fun bindDataCons (cons : (string * Syntax.etype option) list) ((vars, types) : env) : env = + fun bindDataCons (cons : (string * Syntax.etype option) list) (Env env) : env = let val nCons = length cons val (_, vars, types) = foldl (fn ((name, _), (i, vars, types)) => (i + 1, StringMap.insert name (Gensym.new ()) vars, StringMap.insert name (i, nCons) types)) - (0, vars, types) + (0, #vars env, #types env) cons - in (vars, types) + in Env { vars = vars, types = types, structTypes = #structTypes env } end - fun lookupCon (name : string) ((_, types) : env) : int option = - Option.map (fn (i, _) => i) (StringMap.lookup name types) + fun lookupStructType (name : string) (Env env) : env = + case StringMap.lookup name (#structTypes env) of + SOME x => x + | NONE => raise Fail ("unbound structure " ^ name) + + fun lookupCon ([name] : string list) (Env env) : int option = + Option.map (fn (i, _) => i) (StringMap.lookup name (#types env)) + | lookupCon (structName :: names) env = + lookupCon names (lookupStructType structName env) + | lookupCon [] _ = raise Fail "lookupCon empty" - fun nConstructors (name : string) ((_, types) : env) : int = - let val (_, n) = valOf (StringMap.lookup name types) - in n - end + fun nConstructors ([name] : string list) (Env env) : int = + let val (_, n) = valOf (StringMap.lookup name (#types env)) + in n + end + | nConstructors (structName :: names) env = + nConstructors names (lookupStructType structName env) + | nConstructors [] _ = raise Fail "nConstructors empty" fun patternMatrix (arms : Syntax.pat list) : Syntax.pat list list = let val ts = @@ -179,8 +192,8 @@ struct case expr of Syntax.PTuple t => Syntax.PTuple (map (fixConstructors env) t) | Syntax.PVar v => - if isSome (lookupCon v env) - then Syntax.PCon (v, Syntax.PTuple []) + if isSome (lookupCon [v] env) + then Syntax.PCon ([v], Syntax.PTuple []) else Syntax.PVar v | Syntax.PCon (s, p) => Syntax.PCon (s, fixConstructors env p) | _ => expr @@ -236,6 +249,32 @@ struct end end + fun declBoundVars (Syntax.DVal (p, _)) : string list = map (fn (x, _) => x) (patternBindings (Syntax.LInt 0) p) + | declBoundVars (Syntax.DValRec (p, _)) = map (fn (x, _) => x) (patternBindings (Syntax.LInt 0) p) + | declBoundVars (Syntax.DFun (name, _)) = [name] + | declBoundVars (Syntax.DDatatype (_, cons)) = map (fn (x, _) => x) cons + | declBoundVars (Syntax.DStruct (name, _)) = [name] + + fun structBoundVars (decls : Syntax.dec list) : string list = List.concatMap declBoundVars decls + + fun bindStructType (name : string) (decls : Syntax.dec list) (Env env) : env = + let + val structEnv = + foldl + (fn (Syntax.DDatatype (_, cons), env) => bindDataCons cons env + | (Syntax.DStruct (name, decls), env) => bindStructType name decls env + | (_, env) => env) + emptyEnv + decls + val structEnv = + foldl + (fn ((i, n), env) => bindVar n i env) + structEnv + (enumerate (structBoundVars decls)) + in + Env { vars = #vars env, types = #types env, structTypes = StringMap.insert name structEnv (#structTypes env) } + end + fun actionVector (env : env) (expr : Syntax.lexp) (arms : (Syntax.pat * Syntax.expr) list) : Syntax.lexp list = map (fn (p, body) => @@ -280,7 +319,18 @@ struct and elab (env : env) (p : Syntax.expr) : Syntax.lexp = case p of Syntax.EIdent [i] => Syntax.LVar (lookupVar i env) - | Syntax.EIdent _ => raise Fail "long identifiers are not supported" + | Syntax.EIdent (structName :: accessors) => + let + val s = Syntax.LVar (lookupVar structName env) + val env = lookupStructType structName env + fun go env [i] acc = Syntax.LSelect (lookupVar i env, acc) + | go env (accessor :: accessors) acc = + let val env = lookupStructType accessor env + in go env accessors (Syntax.LSelect (lookupVar accessor env, acc)) + end + | go _ [] _ = raise Fail "go empty" + in go env accessors s + end | Syntax.EBuiltin builtin => Syntax.LPrim (primop builtin) | Syntax.EInt i => Syntax.LInt i | Syntax.EStr s => Syntax.LString s @@ -359,6 +409,15 @@ struct ) end end + | Syntax.ELet (Syntax.DStruct (name, structDecls) :: decls, body) => + let + val names = structBoundVars structDecls + val tuple = elab env (Syntax.ELet (structDecls, Syntax.ETuple (map (fn n => Syntax.EIdent [n]) names))) + val v = Gensym.new () + val env = bindStructType name structDecls env + val env = bindVar name v env + in Syntax.LApp (Syntax.LFn (v, elab env (Syntax.ELet (decls, body))), tuple) + end | Syntax.ELambda body => let val v = Gensym.new () in Syntax.LFn (v, elabCase env (Syntax.LVar v) [body]) @@ -368,5 +427,5 @@ struct in Syntax.LApp (Syntax.LFn (v, elabCase env (Syntax.LVar v) arms), elab env expr) end - fun elaborate (p : Syntax.expr) : Syntax.lexp = elab (StringMap.empty, StringMap.empty) p + fun elaborate (p : Syntax.expr) : Syntax.lexp = elab emptyEnv p end @@ -390,12 +390,14 @@ struct (case pats of [p] => p | _ => Syntax.PTuple pats)) - <|> Syntax.PVar <$> identifier) st + <|> bind longIdentifier (fn [i] => const (Syntax.PVar i) | is => const (Syntax.PCon (is, Syntax.PTuple [])))) st and appPat : Syntax.pat parser = fn st => - (bind identifier (fn ident => + (bind longIdentifier (fn ident => bind atpat (fn arg => const (Syntax.PCon (ident, arg))) - <|> const (Syntax.PVar ident)) + <|> const (case ident of + [i] => Syntax.PVar i + | _ => Syntax.PCon (ident, Syntax.PTuple []))) <|> atpat) st and pat : Syntax.pat parser = fn st => foldl @@ -404,14 +406,14 @@ struct fun patLeft pat1 = bind (leftOp i) (fn opEx => bind patLower (fn pat2 => - let val app = Syntax.PCon (opEx, Syntax.PTuple [pat1, pat2]) + let val app = Syntax.PCon ([opEx], Syntax.PTuple [pat1, pat2]) in patLeft app <|> const app end)) fun patRight pat1 = bind (rightOp i) (fn opEx => bind patLower (fn pat2 => bind (patRight pat2 <|> const pat2) (fn rest => - const (Syntax.PCon (opEx, Syntax.PTuple [pat1, rest]))))) + const (Syntax.PCon ([opEx], Syntax.PTuple [pat1, rest]))))) in bind patLower (fn pat1 => patLeft pat1 <|> patRight pat1 <|> const pat1) @@ -565,8 +567,18 @@ struct else const (SOME (Syntax.DFun (name, map (fn (_, x, y) => (x, y)) cases))) end))) st + val rec strdec : Syntax.dec option parser = fn st => + ((reserved "structure" >> + bind identifier (fn strID => + reserved "=" >> + reserved "struct" >> + bind (many strdec) (fn bindings => + reserved "end" >> + const (SOME (Syntax.DStruct (strID, List.mapPartial (fn x => x) bindings)))))) + <|> dec) st + val program : Syntax.expr parser = - bind (many dec) (fn decs => + bind (many strdec) (fn decs => const (Syntax.ELet (List.mapPartial (fn x => x) decs, Syntax.EInt 0))) fun parse (f : string) : (string, Syntax.expr) Result.either = runParser program f end @@ -12,7 +12,7 @@ struct | PVar of string | PInt of int | PTuple of pat list - | PCon of string * pat + | PCon of string list * pat datatype expr = EIdent of string list @@ -34,6 +34,7 @@ struct | DValRec of pat * expr | DFun of string * (pat list * expr) list | DDatatype of string * (string * etype option) list + | DStruct of string * dec list (* Lambda language *) type var = int @@ -127,7 +128,7 @@ struct | PVar v => "PVar " ^ quote v | PInt i => "PInt " ^ Int.toString i | PTuple pats => "PTuple " ^ listToString patToString pats - | PCon (con, v) => "PCon " ^ "(" ^ quote con ^ ", " ^ patToString v ^ ")" + | PCon (con, v) => "PCon " ^ "(" ^ listToString quote con ^ ", " ^ patToString v ^ ")" fun exprToStringI (indent : string) (x : expr) : string = let val self = exprToStringI indent @@ -153,6 +154,7 @@ struct | DValRec (p, e) => "DValRec (" ^ patToString p ^ ", " ^ exprToStringI indent e ^ ")" | DFun (name, cases) => "DFun (" ^ quote name ^ ", " ^ multilineListToString (fn indent => fn (ps, b) => "(" ^ listToString patToString ps ^ ", " ^ exprToStringI indent b ^ ")") indent cases ^ ")" | DDatatype (name, arms) => "DDatatype (" ^ quote name ^ ", " ^ listToString (fn (con, v) => "(" ^ quote con ^ ", " ^ optionToString etypeToString v ^ ")") arms ^ ")" + | DStruct (name, decls) => "DStruct (" ^ quote name ^ ",\n" ^ indent ^ "\t" ^ multilineListToString decToStringI (indent ^ "\t") decls ^ ")" val exprToString : expr -> string = exprToStringI "" diff --git a/tests/20-structure.sml b/tests/20-structure.sml new file mode 100644 index 0000000..dfc7b9b --- /dev/null +++ b/tests/20-structure.sml @@ -0,0 +1,5 @@ +structure S = struct + val fourtyTwo = 42 +end + +val _ = __builtin "exit" S.fourtyTwo diff --git a/tests/21-struct-datatype.sml b/tests/21-struct-datatype.sml new file mode 100644 index 0000000..ab714ea --- /dev/null +++ b/tests/21-struct-datatype.sml @@ -0,0 +1,6 @@ +structure S = struct + datatype D = D of int +end + +val S.D x = S.D 42 +val _ = __builtin "exit" x |