Commit 87a56189 authored by Axel Simon's avatar Axel Simon
Browse files

merge

parents 30e14dc3 dea81567
......@@ -46,6 +46,34 @@ __obj __and (__obj a_, __obj b_) {
return (x);
}
__obj __add (__obj A, __obj B) {
__word a = A->z.value;
__word b = B->z.value;
__LOCAL0(x);
__INT_BEGIN(x);
__INT_INIT(a + b);
__INT_END(x);
return (x);
}
/* FIXME */
__obj __sx (__obj x) {
__LOCAL0(y);
__INT_BEGIN(y);
__INT_INIT(x->bv.vec);
__INT_END(y);
return (y);
}
/* FIXME */
__obj __zx (__obj x) {
__LOCAL0(y);
__INT_BEGIN(y);
__INT_INIT(x->bv.vec);
__INT_END(y);
return (y);
}
__obj __concat (__obj a_, __obj b_) {
__word a = a_->bv.vec;
__word b = b_->bv.vec;
......@@ -188,6 +216,35 @@ __word __decode (__obj (*f)(__obj,__obj), __char* blob, __word sz, __obj* insn)
}
}
__obj __cont (__obj env, __obj f) {
__LOCAL(s,__CLOSURE_REF(env,1));
__LOCAL0(k);
__LABEL_BEGIN(k);
__LABEL_INIT(__halt);
__LABEL_END(k);
__LOCAL0(envK);
__CLOSURE_BEGIN(envK,1)
__CLOSURE_ADD(k);
__CLOSURE_END(envK,1);
return (__INVOKE2(f,envK,s));
}
__obj __translate (__obj (*f)(__obj,__obj), __obj insn) {
__LOCAL0(s);
__RECORD_BEGIN(s,0);
__RECORD_END(s,0);
__LOCAL0(k);
__LABEL_BEGIN(k);
__LABEL_INIT(__cont);
__LABEL_END(k);
__LOCAL0(envK);
__CLOSURE_BEGIN(envK,2)
__CLOSURE_ADD(k);
__CLOSURE_ADD(s);
__CLOSURE_END(envK,2);
return (__CALL2(f,envK,insn));
}
const __char* __fieldName (__word i) {
static __char* unknown = (__char*)"<unknown>";
if (i < __NFIELDS)
......
......@@ -390,6 +390,9 @@ __obj __unconsume(__obj);
__obj __concat(__obj,__obj);
__obj __equal(__obj,__obj);
__obj __and(__obj,__obj);
__obj __sx(__obj);
__obj __zx(__obj);
__obj __add(__obj,__obj);
__obj __raise(__obj);
__obj __not(__obj);
__obj __isNil(__obj);
......@@ -401,6 +404,7 @@ int ___isNil(__obj);
__obj __runWithState(__obj(*)(__obj,__obj),__obj);
__obj __eval(__obj(*)(__obj,__obj),__char*, __word);
__word __decode(__obj(*)(__obj,__obj),__char*,__word,__obj*);
__obj __translate(__obj(*)(__obj,__obj),__obj);
#endif /* __RUNTIME_H */
......
......@@ -8,6 +8,8 @@ structure CompilationMonad : sig
val >> : 'a t * 'b t -> 'b t
val return: 'a -> 'a t
val run: state -> 'a t -> 'a
val mapM : ('a -> 'b t) -> 'a list -> ('b list) t
val fail: 'a t
val getState: state t
val setState: state -> unit t
......@@ -28,28 +30,31 @@ end = struct
type 'answer t = state -> 'answer * state
exception CompilationError
exception Fail of state
fun return v s = (v, s)
fun getState s = (s, s)
fun setState s _ = ((), s)
val getErrorStream: Error.err_stream t = getState
fun fail s = raise CompilationError
fun fail s = raise Fail s
fun aT >>= a2bT = fn s =>
let
val (a, s) =
aT s
handle CompilationError =>
(Error.report (TextIO.stdErr, s)
;raise CompilationError)
val () = Error.report (TextIO.stdErr, s)
in
if Error.anyErrors s
then raise CompilationError
then raise Fail s
else a2bT a s
end
fun const x _ = x
fun aM >> bM = aM >>= const bM
fun mapM f xs = case xs of
[] => return []
| (x :: xs) =>
f x >>= (fn r =>
mapM f xs >>= (fn rs =>
return (r :: rs)))
fun liftErr f a =
getErrorStream >>= (fn errs =>
......@@ -64,8 +69,14 @@ end = struct
val warningAt = liftErr2 Error.warningAt
fun run state action = let
val (b, _) = action state
val (b, s) = action state
handle Fail s =>
(Error.report (TextIO.stdErr, s)
;raise CompilationError)
in
b
if Error.anyErrors s
then (Error.report (TextIO.stdErr, s)
;raise CompilationError)
else b
end
end
......@@ -152,7 +152,7 @@ structure Error :> sig
of LESS => true
| EQUAL => (Position.compare(r1, r2) = LESS)
| GREATER => false))
fun cmp (e1 : error, e2 : error) = lt(#pos e1, #pos e2)
fun cmp (e1 : error, e2 : error) = not (lt(#pos e1, #pos e2))
in
ListMergeSort.sort cmp
end
......@@ -199,8 +199,9 @@ structure Error :> sig
fun printError (outStrm, _) = let
fun pr {kind, pos, msg} = let
val kind = (case kind of ERR => "Error" | Warn => "Warning")
val pos = (case pos
of SOME{file=sm,span=(p1, p2)} => if (p1 = p2)
val pos = (case pos of
NONE => "[no position] "
| SOME{file=sm,span=(p1, p2)} => if (p1 = p2)
then let
val {fileName=SOME f, lineNo, colNo} = SP.sourceLoc sm p1
in
......@@ -234,7 +235,7 @@ structure Error :> sig
pr
end
fun report (outStrm, es as ES{errors, ...}) =
fun report (outStrm, es as ES{errors, numErrors, ...}) =
List.app (printError (outStrm, es)) (sort (!errors))
(* a term marked with a source-map span *)
......
......@@ -15,6 +15,7 @@ structure Aux = struct
fun atomOf x = VarInfo.getAtom (!variables, x)
fun get s = VarInfo.lookup (!variables, Atom.atom s)
fun find s = VarInfo.find (!variables, Atom.atom s)
fun toString sym = Layout.tostring (CPS.PP.var sym)
fun failWithSymbol msg sym =
msg ^ ": " ^ Layout.tostring (CPS.PP.var sym)
......@@ -866,7 +867,12 @@ structure Cost = struct
"binop",
"ternop",
"quaternop"])
;neverInline:=Set.union (!neverInline, Set.fromList (map Aux.get [])))
;neverInline:=
Set.union
(!neverInline,
Set.fromList
(List.mapPartial (fn x=>x)
(List.map Aux.find []))))
val allwaysInline = fn f => Set.member (!allwaysInline, f)
fun dontInline f = neverInline := Set.add (!neverInline, f)
......
......@@ -43,6 +43,39 @@ end = struct
val not = get "not"
val raisee = get "raise"
val return = get "return"
val add = get "+"
val sx = get "sx"
val zx = get "zx"
val sx =
let
val x = fresh "x"
val primSx = get "%sx"
val body = PRI (primSx, [x])
in
(sx, [x], body)
end
val zx =
let
val x = fresh "x"
val primZx = get "%zx"
val body = PRI (primZx, [x])
in
(zx, [x], body)
end
(* val + a b = %add(a,b) *)
val add =
let
val a = fresh "a"
val b = fresh "b"
val primAdd = get "%add"
val body = PRI (primAdd, [a, b])
in
(add, [a, b], body)
end
(* val and a b = %and(a,b) *)
val andd =
......@@ -131,7 +164,7 @@ end = struct
(unconsume, [s], body)
end
in
[slice, consume, unconsume, andd, not, ==, concat, raisee]
[slice, consume, unconsume, andd, not, ==, concat, raisee, add, sx, zx]
end
end
......
......@@ -24,7 +24,7 @@ end = struct
in
case SpecParser.parse lexer ins of
(SOME pt, _, []) => SOME pt
| _ => NONE
| (_,_,ers) => (app (parseErr errStrm) ers;NONE)
end
val parseFile =
......@@ -50,7 +50,9 @@ end = struct
before
(TextIO.closeIn ins;
if Error.anyErrors ers
then raise CompilationMonad.CompilationError
then
(Error.report(TextIO.stdErr,ers)
;raise CompilationMonad.CompilationError)
else ())
end
in
......
......@@ -5,7 +5,6 @@
: KW_case ("case")
| KW_in ("in")
| KW_do ("do")
| KW_datatype ("datatype")
| KW_export ("export")
| KW_div ("div")
| KW_else ("else")
......@@ -103,13 +102,10 @@ Program
Decl
: "granularity" "=" Int => (markDecl (FULL_SPAN, PT.GRANULARITYdecl Int))
| "export" "=" Qid* => (markDecl (FULL_SPAN, PT.EXPORTdecl Qid))
| "datatype" Name "=" ConDecls =>
(markDecl (FULL_SPAN, PT.DATATYPEdecl (Name, ConDecls)))
| "type" Name "=" ConDecls => (markDecl (FULL_SPAN, PT.DATATYPEdecl (Name, ConDecls)))
| "type" Name "=" Ty => (markDecl (FULL_SPAN, PT.TYPEdecl (Name, Ty)))
| "val" Name Name* "=" Exp =>
(markDecl (FULL_SPAN, PT.LETRECdecl (Name1, Name2, Exp)))
| "val" Sym Name* "=" Exp =>
(markDecl (FULL_SPAN, PT.LETRECdecl (Sym, Name, Exp)))
| "val" Name Name* "=" Exp => (markDecl (FULL_SPAN, PT.LETRECdecl (Name1, Name2, Exp)))
| "val" Sym Name* "=" Exp => (markDecl (FULL_SPAN, PT.LETRECdecl (Sym, Name, Exp)))
| "val" Name "[" DecodePat* "]" decl=
( "=" Exp =>
(PT.DECODEdecl (Name, DecodePat, Sum.INL Exp))
......@@ -283,6 +279,7 @@ ValueDecl
Lit
: Int => (PT.INTlit Int)
| STRING => (PT.STRlit STRING)
| "'" "'" => (PT.VEClit "")
| "'" BITSTR "'" => (PT.VEClit BITSTR)
;
......
......@@ -49,12 +49,11 @@ SpecTokens = struct
| KW_else
| KW_div
| KW_export
| KW_datatype
| KW_do
| KW_in
| KW_case
val allToks = [EOF, WILD, COLON, BAR, SEMI, COMMA, TILDE, SLASH, TIMES, MINUS, PLUS, CONCAT, RCB, LCB, RB, LB, RP, LP, DOT, TICK, EQ, BIND, SELECT, WITH, KW_or, KW_and, KW_type, KW_then, KW_raise, KW_granularity, KW_of, KW_mod, KW_val, KW_let, KW_if, KW_end, KW_else, KW_div, KW_export, KW_datatype, KW_do, KW_in, KW_case]
val allToks = [EOF, WILD, COLON, BAR, SEMI, COMMA, TILDE, SLASH, TIMES, MINUS, PLUS, CONCAT, RCB, LCB, RB, LB, RP, LP, DOT, TICK, EQ, BIND, SELECT, WITH, KW_or, KW_and, KW_type, KW_then, KW_raise, KW_granularity, KW_of, KW_mod, KW_val, KW_let, KW_if, KW_end, KW_else, KW_div, KW_export, KW_do, KW_in, KW_case]
fun toString tok =
(case (tok)
......@@ -106,7 +105,6 @@ SpecTokens = struct
| (KW_else) => "else"
| (KW_div) => "div"
| (KW_export) => "export"
| (KW_datatype) => "datatype"
| (KW_do) => "do"
| (KW_in) => "in"
| (KW_case) => "case"
......@@ -161,7 +159,6 @@ SpecTokens = struct
| (KW_else) => false
| (KW_div) => false
| (KW_export) => false
| (KW_datatype) => false
| (KW_do) => false
| (KW_in) => false
| (KW_case) => false
......@@ -229,17 +226,14 @@ fun Decl_PROD_1_ACT (EQ, Int, KW_granularity, EQ_SPAN : (Lex.pos * Lex.pos), Int
( markDecl (FULL_SPAN, PT.GRANULARITYdecl Int))
fun Decl_PROD_2_ACT (EQ, Qid, KW_export, EQ_SPAN : (Lex.pos * Lex.pos), Qid_SPAN : (Lex.pos * Lex.pos), KW_export_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
( markDecl (FULL_SPAN, PT.EXPORTdecl Qid))
fun Decl_PROD_3_ACT (EQ, Name, KW_datatype, ConDecls, EQ_SPAN : (Lex.pos * Lex.pos), Name_SPAN : (Lex.pos * Lex.pos), KW_datatype_SPAN : (Lex.pos * Lex.pos), ConDecls_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
(
markDecl (FULL_SPAN, PT.DATATYPEdecl (Name, ConDecls)))
fun Decl_PROD_3_ACT (EQ, Name, KW_type, ConDecls, EQ_SPAN : (Lex.pos * Lex.pos), Name_SPAN : (Lex.pos * Lex.pos), KW_type_SPAN : (Lex.pos * Lex.pos), ConDecls_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
( markDecl (FULL_SPAN, PT.DATATYPEdecl (Name, ConDecls)))
fun Decl_PROD_4_ACT (EQ, Ty, Name, KW_type, EQ_SPAN : (Lex.pos * Lex.pos), Ty_SPAN : (Lex.pos * Lex.pos), Name_SPAN : (Lex.pos * Lex.pos), KW_type_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
( markDecl (FULL_SPAN, PT.TYPEdecl (Name, Ty)))
fun Decl_PROD_5_ACT (EQ, Exp, Name1, Name2, KW_val, EQ_SPAN : (Lex.pos * Lex.pos), Exp_SPAN : (Lex.pos * Lex.pos), Name1_SPAN : (Lex.pos * Lex.pos), Name2_SPAN : (Lex.pos * Lex.pos), KW_val_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
(
markDecl (FULL_SPAN, PT.LETRECdecl (Name1, Name2, Exp)))
( markDecl (FULL_SPAN, PT.LETRECdecl (Name1, Name2, Exp)))
fun Decl_PROD_6_ACT (EQ, Exp, Sym, Name, KW_val, EQ_SPAN : (Lex.pos * Lex.pos), Exp_SPAN : (Lex.pos * Lex.pos), Sym_SPAN : (Lex.pos * Lex.pos), Name_SPAN : (Lex.pos * Lex.pos), KW_val_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
(
markDecl (FULL_SPAN, PT.LETRECdecl (Sym, Name, Exp)))
( markDecl (FULL_SPAN, PT.LETRECdecl (Sym, Name, Exp)))
fun Decl_PROD_7_SUBRULE_2_PROD_1_ACT (EQ, LB, RB, Exp, Name, DecodePat, KW_val, EQ_SPAN : (Lex.pos * Lex.pos), LB_SPAN : (Lex.pos * Lex.pos), RB_SPAN : (Lex.pos * Lex.pos), Exp_SPAN : (Lex.pos * Lex.pos), Name_SPAN : (Lex.pos * Lex.pos), DecodePat_SPAN : (Lex.pos * Lex.pos), KW_val_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
(
PT.DECODEdecl (Name, DecodePat, Sum.INL Exp))
......@@ -395,7 +389,9 @@ fun Lit_PROD_1_ACT (Int, Int_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos *
( PT.INTlit Int)
fun Lit_PROD_2_ACT (STRING, STRING_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
( PT.STRlit STRING)
fun Lit_PROD_3_ACT (TICK1, TICK2, BITSTR, TICK1_SPAN : (Lex.pos * Lex.pos), TICK2_SPAN : (Lex.pos * Lex.pos), BITSTR_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
fun Lit_PROD_3_ACT (TICK1, TICK2, TICK1_SPAN : (Lex.pos * Lex.pos), TICK2_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
( PT.VEClit "")
fun Lit_PROD_4_ACT (TICK1, TICK2, BITSTR, TICK1_SPAN : (Lex.pos * Lex.pos), TICK2_SPAN : (Lex.pos * Lex.pos), BITSTR_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
( PT.VEClit BITSTR)
fun Int_PROD_1_ACT (POSINT, POSINT_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
( POSINT)
......@@ -626,10 +622,6 @@ fun matchKW_export strm = (case (lex(strm))
of (Tok.KW_export, span, strm') => ((), span, strm')
| _ => fail()
(* end case *))
fun matchKW_datatype strm = (case (lex(strm))
of (Tok.KW_datatype, span, strm') => ((), span, strm')
| _ => fail()
(* end case *))
fun matchKW_do strm = (case (lex(strm))
of (Tok.KW_do, span, strm') => ((), span, strm')
| _ => fail()
......@@ -697,20 +689,33 @@ fun Lit_NT (strm) = let
FULL_SPAN, strm')
end
fun Lit_PROD_3 (strm) = let
val (TICK1_RES, TICK1_SPAN, strm') = matchTICK(strm)
val (TICK2_RES, TICK2_SPAN, strm') = matchTICK(strm')
val FULL_SPAN = (#1(TICK1_SPAN), #2(TICK2_SPAN))
in
(UserCode.Lit_PROD_3_ACT (TICK1_RES, TICK2_RES, TICK1_SPAN : (Lex.pos * Lex.pos), TICK2_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)),
FULL_SPAN, strm')
end
fun Lit_PROD_4 (strm) = let
val (TICK1_RES, TICK1_SPAN, strm') = matchTICK(strm)
val (BITSTR_RES, BITSTR_SPAN, strm') = matchBITSTR(strm')
val (TICK2_RES, TICK2_SPAN, strm') = matchTICK(strm')
val FULL_SPAN = (#1(TICK1_SPAN), #2(TICK2_SPAN))
in
(UserCode.Lit_PROD_3_ACT (TICK1_RES, TICK2_RES, BITSTR_RES, TICK1_SPAN : (Lex.pos * Lex.pos), TICK2_SPAN : (Lex.pos * Lex.pos), BITSTR_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)),
(UserCode.Lit_PROD_4_ACT (TICK1_RES, TICK2_RES, BITSTR_RES, TICK1_SPAN : (Lex.pos * Lex.pos), TICK2_SPAN : (Lex.pos * Lex.pos), BITSTR_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)),
FULL_SPAN, strm')
end
in
(case (lex(strm))
of (Tok.TICK, _, strm') => Lit_PROD_3(strm)
of (Tok.STRING(_), _, strm') => Lit_PROD_2(strm)
| (Tok.POSINT(_), _, strm') => Lit_PROD_1(strm)
| (Tok.NEGINT(_), _, strm') => Lit_PROD_1(strm)
| (Tok.STRING(_), _, strm') => Lit_PROD_2(strm)
| (Tok.TICK, _, strm') =>
(case (lex(strm'))
of (Tok.TICK, _, strm') => Lit_PROD_3(strm)
| (Tok.BITSTR(_), _, strm') => Lit_PROD_4(strm)
| _ => fail()
(* end case *))
| _ => fail()
(* end case *))
end
......@@ -1683,13 +1688,13 @@ fun Decl_NT (strm) = let
FULL_SPAN, strm')
end
fun Decl_PROD_3 (strm) = let
val (KW_datatype_RES, KW_datatype_SPAN, strm') = matchKW_datatype(strm)
val (KW_type_RES, KW_type_SPAN, strm') = matchKW_type(strm)
val (Name_RES, Name_SPAN, strm') = Name_NT(strm')
val (EQ_RES, EQ_SPAN, strm') = matchEQ(strm')
val (ConDecls_RES, ConDecls_SPAN, strm') = ConDecls_NT(strm')
val FULL_SPAN = (#1(KW_datatype_SPAN), #2(ConDecls_SPAN))
val FULL_SPAN = (#1(KW_type_SPAN), #2(ConDecls_SPAN))
in
(UserCode.Decl_PROD_3_ACT (EQ_RES, Name_RES, KW_datatype_RES, ConDecls_RES, EQ_SPAN : (Lex.pos * Lex.pos), Name_SPAN : (Lex.pos * Lex.pos), KW_datatype_SPAN : (Lex.pos * Lex.pos), ConDecls_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)),
(UserCode.Decl_PROD_3_ACT (EQ_RES, Name_RES, KW_type_RES, ConDecls_RES, EQ_SPAN : (Lex.pos * Lex.pos), Name_SPAN : (Lex.pos * Lex.pos), KW_type_SPAN : (Lex.pos * Lex.pos), ConDecls_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)),
FULL_SPAN, strm')
end
fun Decl_PROD_4 (strm) = let
......@@ -1824,10 +1829,25 @@ fun Decl_NT (strm) = let
| (Tok.SYMBOL(_), _, strm') => Decl_PROD_6(strm)
| _ => fail()
(* end case *))
| (Tok.KW_datatype, _, strm') => Decl_PROD_3(strm)
| (Tok.KW_type, _, strm') =>
(case (lex(strm'))
of (Tok.ID(_), _, strm') =>
(case (lex(strm'))
of (Tok.EQ, _, strm') =>
(case (lex(strm'))
of (Tok.CONS(_), _, strm') => Decl_PROD_3(strm)
| (Tok.LCB, _, strm') => Decl_PROD_4(strm)
| (Tok.ID(_), _, strm') => Decl_PROD_4(strm)
| (Tok.POSINT(_), _, strm') => Decl_PROD_4(strm)
| (Tok.NEGINT(_), _, strm') => Decl_PROD_4(strm)
| _ => fail()
(* end case *))
| _ => fail()
(* end case *))
| _ => fail()
(* end case *))
| (Tok.KW_granularity, _, strm') => Decl_PROD_1(strm)
| (Tok.KW_export, _, strm') => Decl_PROD_2(strm)
| (Tok.KW_type, _, strm') => Decl_PROD_4(strm)
| _ => fail()
(* end case *))
end
......@@ -1851,8 +1871,7 @@ fun Program_NT (strm) = let
((Decl_RES), FULL_SPAN, strm')
end
fun Program_PROD_1_SUBRULE_1_PRED (strm) = (case (lex(strm))
of (Tok.KW_datatype, _, strm') => true
| (Tok.KW_export, _, strm') => true
of (Tok.KW_export, _, strm') => true
| (Tok.KW_val, _, strm') => true
| (Tok.KW_granularity, _, strm') => true
| (Tok.KW_type, _, strm') => true
......
......@@ -86,7 +86,6 @@
<INITIAL>"granularity" => (T.KW_granularity);
<INITIAL>"export" => (T.KW_export);
<INITIAL>"datatype" => (T.KW_datatype);
<INITIAL>"type" => (T.KW_type);
<INITIAL>"raise" => (T.KW_raise);
<INITIAL>"if" => (T.KW_if);
......
This diff is collapsed.
......@@ -58,11 +58,11 @@ end = struct
let
val (eStr,si) = E.kappaToStringSI (env,si)
in
(acc ^ "\n\t" ^ str ^ ": " ^ eStr,si)
(acc ^ "\t" ^ str ^ ": " ^ eStr,si)
end
val (str, si) = List.foldl
genRow
(str ^ msg, TVar.emptyShowInfo) envStrs
(str ^ msg ^ "\n", TVar.emptyShowInfo) envStrs
in
raise S.UnificationFailure str
end
......@@ -79,7 +79,27 @@ end = struct
[] => 0
| (f::fs) => List.foldl checkWidth (String.size f) fs
end
(*convert calls in a decoder pattern into a list of monadic actions*)
fun decsToSeq e [] = e
| decsToSeq e ds = AST.SEQexp
(List.concat (List.map decToSeqDecodepat ds) @ [AST.ACTIONseqexp e])
and decToSeqDecodepat (AST.MARKdecodepat {tree=t, span=s}) =
List.map (fn a => AST.MARKseqexp {tree=a, span=s})
(decToSeqDecodepat t)
| decToSeqDecodepat (AST.TOKENdecodepat tp) =
List.map AST.ACTIONseqexp (decToSeqToken tp)
| decToSeqDecodepat (AST.BITdecodepat bps) =
List.map AST.ACTIONseqexp (List.concat (List.map decToSeqBitpat bps))
and decToSeqToken (AST.MARKtokpat {tree=t, span=s}) =
List.map (fn e => AST.MARKexp {tree=e, span=s}) (decToSeqToken t)
| decToSeqToken (AST.NAMEDtokpat sym) = [AST.IDexp sym]
| decToSeqToken _ = []
and decToSeqBitpat (AST.MARKbitpat {tree=t, span=s}) =
List.map (fn e => AST.MARKexp {tree=e, span=s}) (decToSeqBitpat t)
| decToSeqBitpat (AST.NAMEDbitpat sym) = [AST.IDexp sym]
| decToSeqBitpat _ = []
fun typeInferencePass (errStrm, ti : TI.type_info, ast) = let
val sm = ref ([] : symbol_types)
val { tsynDefs, typeDefs, conParents} = ti
......@@ -174,7 +194,7 @@ fun typeInferencePass (errStrm, ti : TI.type_info, ast) = let
List.filter (fn (s,_) =>
not (SymbolTable.eq_symid(s,sym))) sm)
(!sm) changed
val affectedSyms = E.affectedFunctions (substs,env)
val affectedSyms = E.affectedFunctions (substs,envCall)
val _ = raiseWarning (substs, affectedSyms)
in
(E.SymbolSet.union (unstable, affectedSyms), env)
......@@ -245,6 +265,7 @@ fun typeInferencePass (errStrm, ti : TI.type_info, ast) = let
case infDecodepat sym (st,env) d of (nArgs, env) => (n+nArgs, env)
val (n,env) = List.foldl pushDecoderBindings (0,env) dec
val env = List.foldl E.pushLambdaVar env args
val rhs = decsToSeq rhs dec
val env = infExp (st,env) rhs
val env = E.reduceToFunction (env, List.length args)
val env = E.return (n,env)
......@@ -395,7 +416,11 @@ fun typeInferencePass (errStrm, ti : TI.type_info, ast) = let
handle S.UnificationFailure str =>
refineError (str,
" while passing",
List.map (fn e2 => (envArg, "argument " ^ showProg (20, PP.exp, e2))) es2 @
(#1 (List.foldr
(fn (e2,(res,env)) =>
((env, "argument " ^ showProg (20, PP.exp, e2))::res,
E.popKappa env)
) ([], envArg) es2)) @
[(envFun, "to function " ^ showProg (20, PP.exp, e1))])
(*val _ = TextIO.print ("**** app fun,res unified:\n" ^ E.topToString env)*)
val env = E.reduceToResult env
......@@ -684,7 +709,7 @@ fun typeInferencePass (errStrm, ti : TI.type_info, ast) = let
(ast : SpecAbstractTree.specification)
val toplevelEnv = calcFixpoint (unstable, toplevelEnv)
handle TypeError => toplevelEnv
val _ = TextIO.print ("toplevel environment:\n" ^ E.toString toplevelEnv)
(*val _ = TextIO.print ("toplevel environment:\n" ^ E.toString toplevelEnv)*)
(* check if all exported functions can be run with an empty state *)
fun checkDecoder s sym = case E.forceNoInputs (sym,toplevelEnv) of
......
......@@ -100,6 +100,10 @@ structure Primitives = struct
flow = noFlow},
{name="%raise", ty=UNIT, flow = noFlow},
{name="%and", ty=UNIT, flow = noFlow},
{name="%sx", ty=UNIT, flow = noFlow},
{name="%zx", ty=UNIT, flow = noFlow},
{name="%add", ty=UNIT, flow = noFlow},
{name="%sub", ty=UNIT, flow = noFlow},
{name="%not", ty=UNIT, flow = noFlow},
{name="%equal", ty=UNIT, flow = noFlow},
{name="%concat", ty=UNIT, flow = noFlow},
......@@ -137,11 +141,13 @@ structure Primitives = struct
flow = BD.meetVarImpliesVar (bvar g', bvar g) o
BD.meetVarImpliesVar (bvar stateI', bvar stateI) o
BD.meetVarImpliesVar (bvar stateI'', bvar stateI) },
{name="+", ty=vvv s1,
{name="+", ty=FUN([ZENO,ZENO],ZENO),flow=noFlow},
{name="-", ty=FUN([ZENO,ZENO],ZENO),flow=noFlow},
{name="++", ty=vvv s1,
flow = BD.meetVarZero (bvar s1)},
{name="-", ty=vvv s2,
{name="--", ty=vvv s2,