summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Elab.sml36
-rw-r--r--Parser.sml24
-rw-r--r--ShowSyntax.sml4
-rw-r--r--Syntax.sml2
-rw-r--r--Types.sml24
-rw-r--r--tests/010-simple.sml (renamed from tests/01-simple.sml)0
-rw-r--r--tests/020-lambda.sml (renamed from tests/02-lambda.sml)0
-rw-r--r--tests/030-arg.sml (renamed from tests/03-arg.sml)0
-rw-r--r--tests/040-val.sml (renamed from tests/04-val.sml)0
-rw-r--r--tests/050-let.sml (renamed from tests/05-let.sml)0
-rw-r--r--tests/060-let-multiple.sml (renamed from tests/06-let-multiple.sml)0
-rw-r--r--tests/070-add.sml (renamed from tests/07-add.sml)0
-rw-r--r--tests/080-multiply.sml (renamed from tests/08-multiply.sml)0
-rw-r--r--tests/090-subtract.sml (renamed from tests/09-subtract.sml)0
-rw-r--r--tests/100-divide.sml (renamed from tests/10-divide.sml)0
-rw-r--r--tests/110-case.sml (renamed from tests/11-case.sml)0
-rw-r--r--tests/120-case-int.sml (renamed from tests/12-case-int.sml)0
-rw-r--r--tests/130-fibonacci.sml (renamed from tests/13-fibonacci.sml)0
-rw-r--r--tests/140-fun.sml (renamed from tests/14-fun.sml)0
-rw-r--r--tests/150-tuple.sml (renamed from tests/15-tuple.sml)0
-rw-r--r--tests/155-case-tuple.sml4
-rw-r--r--tests/160-datatype.sml (renamed from tests/16-datatype.sml)0
-rw-r--r--tests/170-case-datatype.sml (renamed from tests/17-case-datatype.sml)0
-rw-r--r--tests/175-case-datatype-default.sml6
-rw-r--r--tests/180-fun-case.sml (renamed from tests/18-fun-case.sml)0
-rw-r--r--tests/190-list.sml (renamed from tests/19-list.sml)1
-rw-r--r--tests/200-structure.sml (renamed from tests/20-structure.sml)0
-rw-r--r--tests/210-struct-datatype.sml (renamed from tests/21-struct-datatype.sml)0
-rw-r--r--tests/220-nested-struct.sml (renamed from tests/22-nested-struct.sml)0
-rw-r--r--tests/225-two-structs.sml9
-rw-r--r--tests/230-signature.sml (renamed from tests/23-signature.sml)0
-rw-r--r--tests/240-functor.sml (renamed from tests/24-functor.sml)0
-rw-r--r--tests/250-list.sml6
-rw-r--r--tests/260-cons.sml4
34 files changed, 103 insertions, 17 deletions
diff --git a/Elab.sml b/Elab.sml
index ba436f5..13bc890 100644
--- a/Elab.sml
+++ b/Elab.sml
@@ -59,6 +59,8 @@ struct
fun patternBindings (expr : Syntax.lexp) (Syntax.TPVar v, _ : Syntax.ty) : (string * Syntax.lexp) list = [(v, expr)]
| patternBindings expr (Syntax.TPTuple t, _) =
List.concat (map (fn (i, p) => patternBindings (Syntax.LSelect (i, expr)) p) (enumerate t))
+ | patternBindings _ (Syntax.TPList [], _) = []
+ | patternBindings expr (Syntax.TPList (x :: xs), t) = patternBindings (Syntax.LSelect (0, Syntax.LSelect (1, expr))) x @ patternBindings (Syntax.LSelect (1, Syntax.LSelect (1, expr))) (Syntax.TPList xs, t)
| patternBindings expr (Syntax.TPCon (_, arg), _) = patternBindings (Syntax.LSelect (1, expr)) arg
| patternBindings _ _ = []
@@ -117,11 +119,15 @@ struct
val con1 =
List.find
(fn (Syntax.TPCon (name, _), Syntax.TDatatype cons) => lookupCon (List.last name) cons = n
+ | (Syntax.TPList [], _) => n = 0
+ | (_, Syntax.TList _) => n = 1
| _ => false)
(map hd patterns)
val newTupleSize =
case con1 of
SOME (Syntax.TPCon (_, (Syntax.TPTuple t, _)), _) => length t
+ | SOME (Syntax.TPList [], _) => 0
+ | SOME (_, Syntax.TList _) => 2
| _ => 0
val occHead = hd occurrences
val occRest = tl occurrences
@@ -130,10 +136,17 @@ struct
then Syntax.LSelect (1, occHead) :: occRest
else
List.tabulate (newTupleSize, fn i => Syntax.LSelect (i, Syntax.LSelect (1, occHead))) @ occRest
+ val newTupleSize = if newTupleSize = 0 then 1 else newTupleSize
fun specializeRow ((Syntax.TPInt i, ty):: rest) =
if i = n then SOME ((Syntax.TPWild, ty) :: rest) else NONE
- | specializeRow ((Syntax.TPWild, ty) :: rest) = SOME ((Syntax.TPWild, ty) :: rest)
- | specializeRow ((Syntax.TPVar _, ty) :: rest) = SOME ((Syntax.TPWild, ty) :: rest)
+ | specializeRow ((Syntax.TPWild, ty) :: rest) = SOME (List.tabulate (newTupleSize, fn _ => (Syntax.TPWild, ty)) @ rest)
+ | specializeRow ((Syntax.TPVar _, ty) :: rest) = SOME (List.tabulate (newTupleSize, fn _ => (Syntax.TPWild, ty)) @ rest)
+ | specializeRow ((Syntax.TPList [], Syntax.TList ty) :: rest) =
+ if n = 0 then SOME ((Syntax.TPWild, ty) :: rest) else NONE
+ | specializeRow ((Syntax.TPList (pat :: pats), ty) :: rest) =
+ if n = 1 then SOME ([pat, (Syntax.TPList pats, ty)] @ rest) else NONE
+ | specializeRow ((Syntax.TPCon (_, (Syntax.TPTuple pats, _)), Syntax.TList _) :: rest) =
+ if n = 1 then SOME (pats @ rest) else NONE
| specializeRow ((Syntax.TPCon (con, (Syntax.TPTuple [], tupleTy)), conTy) :: rest) =
specializeRow ((Syntax.TPCon (con, (Syntax.TPTuple [(Syntax.TPWild, Syntax.TTuple [])], tupleTy)), conTy) :: rest)
| specializeRow ((Syntax.TPCon (con, (Syntax.TPTuple args, _)), Syntax.TDatatype cons) :: rest) =
@@ -172,6 +185,7 @@ struct
List.find
(fn (_, (Syntax.TPInt _, _)) => true
| (_, (Syntax.TPCon _, _)) => true
+ | (_, (Syntax.TPList _, _)) => true
| _ => false)
(enumerate firstRow)
in
@@ -189,13 +203,16 @@ struct
(IntMap.toList
(foldl
(fn ((Syntax.TPInt i, _), acc) => IntMap.insert i true acc
+ | ((Syntax.TPList [], _), acc) => IntMap.insert 0 true acc
+ | ((_, Syntax.TList _), acc) => IntMap.insert 1 true acc
| ((Syntax.TPCon (c, _), Syntax.TDatatype cons), acc) => IntMap.insert (lookupCon (List.last c) cons) true acc
| (_, acc) => acc)
IntMap.empty
firstCol))
val nCons =
- case List.find (fn (Syntax.TPCon _, _) => true | _ => false) firstCol of
+ case List.find (fn (Syntax.TPCon _, _) => true | (Syntax.TPList _, _) => true | _ => false) firstCol of
SOME (Syntax.TPCon _, Syntax.TDatatype cons) => length cons
+ | SOME (_, Syntax.TList _) => 2
| _ => ~1
val defaultCase =
if length signatures = nCons
@@ -273,8 +290,8 @@ struct
| Syntax.TEList exprs =>
foldr
(fn (x, acc) =>
- Syntax.LRecord [elab env x, acc])
- (Syntax.LInt 0)
+ Syntax.LRecord [Syntax.LInt 1, Syntax.LRecord [elab env x, acc]])
+ (Syntax.LRecord [Syntax.LInt 0])
exprs
| Syntax.TEApp (f, x) => Syntax.LApp (elab env f, elab env x)
| Syntax.TEAndAlso (_, _) => raise Fail "unimplemented"
@@ -400,5 +417,12 @@ struct
in Syntax.LApp (func, tuple) end
| _ => raise Fail ("invalid expression " ^ ShowSyntax.typedExprToString p)
- fun elaborate (p : Syntax.typedExpr * Syntax.ty) : Syntax.lexp = elab emptyEnv p
+ fun elaborate (p : Syntax.typedExpr * Syntax.ty) : Syntax.lexp =
+ let
+ val cons = GenSym.new ()
+ val alpha = GenSym.new ()
+ val env = IdentMap.insert (Syntax.ITVar, "::") cons emptyEnv
+ in
+ Syntax.LApp (Syntax.LFn (cons, elab env p), Syntax.LFn (alpha, Syntax.LRecord [Syntax.LInt 1, Syntax.LVar alpha]))
+ end
end
diff --git a/Parser.sml b/Parser.sml
index 8f43352..9f31f8d 100644
--- a/Parser.sml
+++ b/Parser.sml
@@ -28,8 +28,18 @@ struct
, "signature", "struct", "structure", "where", ":>"
]
- val emptyInfixOperators : infixTable =
- Vector.tabulate (10, fn _ => ([], []))
+ val defaultInfixOperators : infixTable = Vector.fromList
+ [ ([], [])
+ , ([], [])
+ , ([], [])
+ , ([], [])
+ , ([], [])
+ , ([], ["::"])
+ , ([], [])
+ , ([], [])
+ , ([], [])
+ , ([], [])
+ ]
fun printSourceLoc ({file, row, column} : sourceLoc) : string =
file ^ ":" ^ Int.toString row ^ "." ^ Int.toString column
@@ -69,7 +79,7 @@ struct
fun newState (fileName : string) (fileStream : TextIO.instream) : state = {
stream = TextIO.getInstream fileStream,
loc = newLoc fileName,
- userState = {infixTable = emptyInfixOperators}
+ userState = {infixTable = defaultInfixOperators}
}
fun updateUserState (f : userState -> userState) : userState parser =
@@ -414,6 +424,10 @@ struct
val rec atpat : Syntax.pat parser = fn st =>
(Syntax.PWild <$ reserved "_"
<|> Syntax.PInt <$> integer
+ <|> (symbol "[" >>
+ bind (sepBy pat (symbol ",")) (fn pats =>
+ symbol "]" >>
+ const (Syntax.PList pats)))
<|> bind (between (symbol "(") (symbol ")") (sepBy pat (symbol ","))) (fn pats =>
const
(case pats of
@@ -476,6 +490,10 @@ struct
bind expr (fn e =>
reserved "end" >>
const (Syntax.ELet (List.mapPartial (fn x => x) decs, e)))))
+ <|> (symbol "[" >>
+ bind (sepBy expr (symbol ",")) (fn exprs =>
+ symbol "]" >>
+ const (Syntax.EList exprs)))
<|> (symbol "(" >>
bind (sepBy expr (symbol ",")) (fn exprs =>
symbol ")" >>
diff --git a/ShowSyntax.sml b/ShowSyntax.sml
index 519fb2b..70f082b 100644
--- a/ShowSyntax.sml
+++ b/ShowSyntax.sml
@@ -44,6 +44,8 @@ and patToStringI (indent : string) (Syntax.PWild : Syntax.pat) : string =
"PTuple " ^ listToString (patToStringI) indent x
| patToStringI (indent : string) (Syntax.PCon x : Syntax.pat) : string =
"PCon " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ listToString (stringToStringI) indent' x0 ^ ",\n" ^ indent' ^ patToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent x
+ | patToStringI (indent : string) (Syntax.PList x : Syntax.pat) : string =
+ "PList " ^ listToString (patToStringI) indent x
and patToString (x : Syntax.pat) : string = patToStringI "" x
and identTypeToStringI (indent : string) (Syntax.ITVar : Syntax.identType) : string =
@@ -140,6 +142,8 @@ and typedPatToStringI (indent : string) (Syntax.TPWild : Syntax.typedPat) : stri
"TPTuple " ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedPatToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end)) indent x
| typedPatToStringI (indent : string) (Syntax.TPCon x : Syntax.typedPat) : string =
"TPCon " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ listToString (stringToStringI) indent' x0 ^ ",\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedPatToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x
+ | typedPatToStringI (indent : string) (Syntax.TPList x : Syntax.typedPat) : string =
+ "TPList " ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedPatToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end)) indent x
and typedPatToString (x : Syntax.typedPat) : string = typedPatToStringI "" x
and typedExprToStringI (indent : string) (Syntax.TEIdent x : Syntax.typedExpr) : string =
diff --git a/Syntax.sml b/Syntax.sml
index 0eccd36..8145211 100644
--- a/Syntax.sml
+++ b/Syntax.sml
@@ -13,6 +13,7 @@ struct
| PInt of int
| PTuple of pat list
| PCon of string list * pat
+ | PList of pat list
datatype identType =
ITVar
@@ -77,6 +78,7 @@ struct
| TPInt of int
| TPTuple of (typedPat * ty) list
| TPCon of string list * (typedPat * ty)
+ | TPList of (typedPat * ty) list
datatype typedExpr =
TEIdent of identType * string
diff --git a/Types.sml b/Types.sml
index 6b945f9..6cf419f 100644
--- a/Types.sml
+++ b/Types.sml
@@ -148,6 +148,8 @@ structure Types = struct
bind makeBinding (Syntax.ITVar, v) (GenSym.new ()) env
| bindPat makeBinding (Syntax.PTuple pats) env =
foldl (fn (pat, env) => bindPat makeBinding pat env) env pats
+ | bindPat makeBinding (Syntax.PList pats) env =
+ foldl (fn (pat, env) => bindPat makeBinding pat env) env pats
| bindPat makeBinding (Syntax.PCon (_, pat)) env = bindPat makeBinding pat env
| bindPat _ _ env = env
@@ -157,11 +159,6 @@ structure Types = struct
| SOME (Arg t) => TyVar t
| NONE => raise Fail ("unbound var " ^ printIdent name)
- fun patBindings (Syntax.PVar v) : string list = [v]
- | patBindings (Syntax.PTuple pats) = List.concat (map patBindings pats)
- | patBindings (Syntax.PCon (_, pat)) = patBindings pat
- | patBindings _ = []
-
fun tyToSyntaxTy (TyVar v) = Syntax.TVar v
| tyToSyntaxTy (TyCon (Bool, [])) = Syntax.TBool
| tyToSyntaxTy (TyCon (Int, [])) = Syntax.TInt
@@ -220,6 +217,13 @@ structure Types = struct
Syntax.PTuple [] => (Syntax.TPCon (con, (Syntax.TPTuple [], Syntax.TTuple [])), conType)
| _ => raise Fail ("non-function " ^ (String.concatWith "." con) ^ " applied to argument in pattern")
end
+ | tagPat env (Syntax.PList pats) =
+ let
+ val taggedPats = map (tagPat env) pats
+ val elemType = TyVar (GenSym.new ())
+ val _ = app (fn (_, t) => unify elemType t) taggedPats
+ in (Syntax.TPList (map (fn (x, t) => (x, tyToSyntaxTy t)) taggedPats), TyCon (List, [elemType]))
+ end
fun F (env : env) (Syntax.EIdent i) : Syntax.typedExpr * ty =
(Syntax.TEIdent i, lookupBinding i env)
@@ -306,7 +310,7 @@ structure Types = struct
arms
in (Syntax.TECase ((arg, tyToSyntaxTy argType), arms), resultType) end
| F env (Syntax.EStruct decls) =
- let val (env, decls) = tagDecs env decls
+ let val (env', decls) = tagDecs env decls
in
( Syntax.TEStruct decls
, TyStruct
@@ -314,7 +318,9 @@ structure Types = struct
(map
(fn (name, Let v) => (name, TyVar v)
| (name, Arg v) => (name, TyVar v))
- (IdentMap.toList (#bindings env))))
+ (List.filter
+ (fn (id, _) => not (isSome (IdentMap.lookup id (#bindings env))))
+ (IdentMap.toList (#bindings env')))))
)
end
| F env (Syntax.EFunctorApp (func, arg)) =
@@ -465,6 +471,10 @@ structure Types = struct
, boundVars = TyVarMap.empty
, typesByName = StringMap.empty
}
+ val alpha = TyVar (GenSym.new ())
+ val cons = GenSym.new ()
+ val _ = unify (TyVar cons) (TyCon (Fun, [TyCon (Tuple, [alpha, TyCon (List, [alpha])]), TyCon (List, [alpha])]))
+ val env = bind Let (Syntax.ITVar, "::") cons env
val (expr, ty) = F env expr
in reexpand (expr, tyToSyntaxTy ty) end
end
diff --git a/tests/01-simple.sml b/tests/010-simple.sml
index e41f9b4..e41f9b4 100644
--- a/tests/01-simple.sml
+++ b/tests/010-simple.sml
diff --git a/tests/02-lambda.sml b/tests/020-lambda.sml
index 41470a2..41470a2 100644
--- a/tests/02-lambda.sml
+++ b/tests/020-lambda.sml
diff --git a/tests/03-arg.sml b/tests/030-arg.sml
index 8d10139..8d10139 100644
--- a/tests/03-arg.sml
+++ b/tests/030-arg.sml
diff --git a/tests/04-val.sml b/tests/040-val.sml
index 20d07b4..20d07b4 100644
--- a/tests/04-val.sml
+++ b/tests/040-val.sml
diff --git a/tests/05-let.sml b/tests/050-let.sml
index d1c27f5..d1c27f5 100644
--- a/tests/05-let.sml
+++ b/tests/050-let.sml
diff --git a/tests/06-let-multiple.sml b/tests/060-let-multiple.sml
index 47441ac..47441ac 100644
--- a/tests/06-let-multiple.sml
+++ b/tests/060-let-multiple.sml
diff --git a/tests/07-add.sml b/tests/070-add.sml
index 9892b23..9892b23 100644
--- a/tests/07-add.sml
+++ b/tests/070-add.sml
diff --git a/tests/08-multiply.sml b/tests/080-multiply.sml
index d75c316..d75c316 100644
--- a/tests/08-multiply.sml
+++ b/tests/080-multiply.sml
diff --git a/tests/09-subtract.sml b/tests/090-subtract.sml
index 2374816..2374816 100644
--- a/tests/09-subtract.sml
+++ b/tests/090-subtract.sml
diff --git a/tests/10-divide.sml b/tests/100-divide.sml
index a701180..a701180 100644
--- a/tests/10-divide.sml
+++ b/tests/100-divide.sml
diff --git a/tests/11-case.sml b/tests/110-case.sml
index 297ae5b..297ae5b 100644
--- a/tests/11-case.sml
+++ b/tests/110-case.sml
diff --git a/tests/12-case-int.sml b/tests/120-case-int.sml
index 98967e4..98967e4 100644
--- a/tests/12-case-int.sml
+++ b/tests/120-case-int.sml
diff --git a/tests/13-fibonacci.sml b/tests/130-fibonacci.sml
index ec89f70..ec89f70 100644
--- a/tests/13-fibonacci.sml
+++ b/tests/130-fibonacci.sml
diff --git a/tests/14-fun.sml b/tests/140-fun.sml
index 210b30d..210b30d 100644
--- a/tests/14-fun.sml
+++ b/tests/140-fun.sml
diff --git a/tests/15-tuple.sml b/tests/150-tuple.sml
index 114fd25..114fd25 100644
--- a/tests/15-tuple.sml
+++ b/tests/150-tuple.sml
diff --git a/tests/155-case-tuple.sml b/tests/155-case-tuple.sml
new file mode 100644
index 0000000..774fb34
--- /dev/null
+++ b/tests/155-case-tuple.sml
@@ -0,0 +1,4 @@
+val _ = __builtin "exit"
+ (case (1, 2, 42) of
+ (_, 2, x) => x
+ | _ => 13)
diff --git a/tests/16-datatype.sml b/tests/160-datatype.sml
index 7514606..7514606 100644
--- a/tests/16-datatype.sml
+++ b/tests/160-datatype.sml
diff --git a/tests/17-case-datatype.sml b/tests/170-case-datatype.sml
index 974f263..974f263 100644
--- a/tests/17-case-datatype.sml
+++ b/tests/170-case-datatype.sml
diff --git a/tests/175-case-datatype-default.sml b/tests/175-case-datatype-default.sml
new file mode 100644
index 0000000..221bc13
--- /dev/null
+++ b/tests/175-case-datatype-default.sml
@@ -0,0 +1,6 @@
+datatype D = A of int * int | B
+
+val _ = __builtin "exit"
+ (case A (42, 13) of
+ A (x, 13) => x
+ | _ => 10)
diff --git a/tests/18-fun-case.sml b/tests/180-fun-case.sml
index d64b7d7..d64b7d7 100644
--- a/tests/18-fun-case.sml
+++ b/tests/180-fun-case.sml
diff --git a/tests/19-list.sml b/tests/190-list.sml
index 52404dc..de69c4a 100644
--- a/tests/19-list.sml
+++ b/tests/190-list.sml
@@ -1,5 +1,4 @@
infix 6 +
-infixr 5 ::
datatype 'a list = Nil | :: of 'a * 'a list
diff --git a/tests/20-structure.sml b/tests/200-structure.sml
index dfc7b9b..dfc7b9b 100644
--- a/tests/20-structure.sml
+++ b/tests/200-structure.sml
diff --git a/tests/21-struct-datatype.sml b/tests/210-struct-datatype.sml
index ab714ea..ab714ea 100644
--- a/tests/21-struct-datatype.sml
+++ b/tests/210-struct-datatype.sml
diff --git a/tests/22-nested-struct.sml b/tests/220-nested-struct.sml
index 1eaf6ab..1eaf6ab 100644
--- a/tests/22-nested-struct.sml
+++ b/tests/220-nested-struct.sml
diff --git a/tests/225-two-structs.sml b/tests/225-two-structs.sml
new file mode 100644
index 0000000..465840f
--- /dev/null
+++ b/tests/225-two-structs.sml
@@ -0,0 +1,9 @@
+structure A = struct
+ val fourtyTwo = 42
+end
+val B = 10
+structure X = struct
+ val Y = A.fourtyTwo
+end
+
+val _ = __builtin "exit" X.Y
diff --git a/tests/23-signature.sml b/tests/230-signature.sml
index 01a8494..01a8494 100644
--- a/tests/23-signature.sml
+++ b/tests/230-signature.sml
diff --git a/tests/24-functor.sml b/tests/240-functor.sml
index d18337e..d18337e 100644
--- a/tests/24-functor.sml
+++ b/tests/240-functor.sml
diff --git a/tests/250-list.sml b/tests/250-list.sml
new file mode 100644
index 0000000..4aeecf2
--- /dev/null
+++ b/tests/250-list.sml
@@ -0,0 +1,6 @@
+val _ = __builtin "exit"
+ (case [1, 2, 42] of
+ [] => 10
+ | [x] => x
+ | [_, _, x] => x
+ | _ => 13)
diff --git a/tests/260-cons.sml b/tests/260-cons.sml
new file mode 100644
index 0000000..f01cefe
--- /dev/null
+++ b/tests/260-cons.sml
@@ -0,0 +1,4 @@
+val _ = __builtin "exit"
+ (case 42 :: [] of
+ x :: _ => x
+ | _ => 13)
generated by cgit v1.3.1 (git 2.54.0) at 2026-09-04 05:22:05 +0000