Commit ee496719 authored by Axel Simon's avatar Axel Simon
Browse files

add syntax to remove field

parent c6a7e8f0
......@@ -59,7 +59,7 @@ structure DesugaredTree = struct
| APPLYexp (e1, es) => Exp.APP (exp e1, map exp es)
| RECORDexp fs => Exp.RECORD (fields fs)
| SELECTexp f => Exp.SELECT f
| UPDATEexp fs => Exp.UPDATE (fields fs)
| UPDATEexp fs => Exp.UPDATE (fieldsOpt fs)
| LITexp l => Exp.LIT l
| CONexp c => Exp.CON c
| SEQexp seq => Exp.SEQ (map seqexp seq)
......@@ -72,6 +72,15 @@ structure DesugaredTree = struct
| OPinfixop binop => Exp.ID binop
and fields fs = map (fn (f, e) => (f, exp e)) fs
and fieldsOpt fs =
let
fun mapUpdates ((f, SOME e) :: fes) = (f, exp e) :: mapUpdates fes
| mapUpdates ((f, NONE) :: fes) = mapUpdates fes
| mapUpdates [] = []
in
mapUpdates fs
end
and match (p, e) = (pat p, exp e)
......
......@@ -49,8 +49,8 @@ structure ASTSubst = struct
APPLYexp (visitExp sigma e, map (visitExp sigma) es)
| RECORDexp fs =>
RECORDexp (map (visitField sigma) fs)
| UPDATEexp fs =>
UPDATEexp (map (visitField sigma) fs)
| UPDATEexp fs =>
UPDATEexp (map (visitFieldOpt sigma) fs)
| SEQexp es =>
SEQexp (map (visitSeqexp sigma) es)
| FNexp (x, e) =>
......@@ -62,6 +62,7 @@ structure ASTSubst = struct
and visitRec sigma (f, xs, e) = (f, xs, visitExp sigma e)
and visitCase sigma (pat, e) = (pat, visitExp sigma e)
and visitField sigma (f, e) = (f, visitExp sigma e)
and visitFieldOpt sigma (f, eOpt) = (f, Option.map (visitExp sigma) eOpt)
and visitSeqexp sigma t =
case t of
MARKseqexp t => visitSeqexp sigma (#tree t)
......
......@@ -67,7 +67,7 @@ functor MkAst (Core: AST_CORE) = struct
| APPLYexp of exp * exp list
| RECORDexp of (field_bind * exp) list
| SELECTexp of field_use
| UPDATEexp of (field_bind * exp) list (* functional record update "@{a=a'} *)
| UPDATEexp of (field_bind * exp option) list (* functional record update "@{a=a'} *)
| LITexp of lit
| SEQexp of seqexp list (* monadic sequence *)
| IDexp of var_use
......@@ -231,7 +231,7 @@ functor MkAst (Core: AST_CORE) = struct
| APPLYexp (e1, es) => seq [exp e1, list (map exp es)]
| RECORDexp fs => listex "{" "}" "," (map field fs)
| SELECTexp f => seq [str "$", field_use f]
| UPDATEexp fs => seq [str "@", listex "{" "}" "," (map field fs)]
| UPDATEexp fs => seq [str "@", listex "{" "}" "," (map fieldOpt fs)]
| LITexp l => lit l
| SEQexp ss =>
align
......@@ -266,6 +266,9 @@ functor MkAst (Core: AST_CORE) = struct
and field (n, e) = seq [field_bind n, str "=", exp e]
and fieldOpt (n, SOME e) = seq [field_bind n, str "=", exp e]
| fieldOpt (n, NONE) = seq [str "~", field_bind n]
and casee (p, e) =
align
[seq [pat p, space, str ":"],
......
......@@ -261,8 +261,8 @@ AtomicExp
: Lit => (mark PT.MARKexp (FULL_SPAN, PT.LITexp Lit))
| Qid => (mark PT.MARKexp (FULL_SPAN, PT.IDexp Qid))
| ConUse => (mark PT.MARKexp (FULL_SPAN, PT.CONexp ConUse))
| "@" "{" Name "=" Exp ("," Name "=" Exp)* "}" =>
(mark PT.MARKexp (FULL_SPAN, PT.UPDATEexp ((Name, Exp)::SR)))
| "@" "{" Field ("," Field)* "}" =>
(mark PT.MARKexp (FULL_SPAN, PT.UPDATEexp (Field::SR)))
| "$" Qid => (mark PT.MARKexp (FULL_SPAN, PT.SELECTexp Qid))
| "(" Exp ")" => (mark PT.MARKexp (FULL_SPAN, Exp))
| "{" "}" => (mark PT.MARKexp (FULL_SPAN, PT.RECORDexp []))
......@@ -272,6 +272,11 @@ AtomicExp
(mark PT.MARKexp (FULL_SPAN, PT.LETRECexp (ValueDecl, Exp)))
;
Field
: Name "=" Exp => ((Name, SOME Exp))
| "~" Name => ((Name, NONE))
;
ValueDecl
: "val" Name Name* "=" Exp => (Name1, Name2, Exp)
;
......
......@@ -374,9 +374,9 @@ fun AtomicExp_PROD_2_ACT (Qid, Qid_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.
( mark PT.MARKexp (FULL_SPAN, PT.IDexp Qid))
fun AtomicExp_PROD_3_ACT (ConUse, ConUse_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
( mark PT.MARKexp (FULL_SPAN, PT.CONexp ConUse))
fun AtomicExp_PROD_4_ACT (EQ, SR, Exp, LCB, RCB, Name, WITH, EQ_SPAN : (Lex.pos * Lex.pos), SR_SPAN : (Lex.pos * Lex.pos), Exp_SPAN : (Lex.pos * Lex.pos), LCB_SPAN : (Lex.pos * Lex.pos), RCB_SPAN : (Lex.pos * Lex.pos), Name_SPAN : (Lex.pos * Lex.pos), WITH_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
fun AtomicExp_PROD_4_ACT (SR, LCB, RCB, WITH, Field, SR_SPAN : (Lex.pos * Lex.pos), LCB_SPAN : (Lex.pos * Lex.pos), RCB_SPAN : (Lex.pos * Lex.pos), WITH_SPAN : (Lex.pos * Lex.pos), Field_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
(
mark PT.MARKexp (FULL_SPAN, PT.UPDATEexp ((Name, Exp)::SR)))
mark PT.MARKexp (FULL_SPAN, PT.UPDATEexp (Field::SR)))
fun AtomicExp_PROD_5_ACT (Qid, SELECT, Qid_SPAN : (Lex.pos * Lex.pos), SELECT_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
( mark PT.MARKexp (FULL_SPAN, PT.SELECTexp Qid))
fun AtomicExp_PROD_6_ACT (LP, RP, Exp, LP_SPAN : (Lex.pos * Lex.pos), RP_SPAN : (Lex.pos * Lex.pos), Exp_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
......@@ -389,6 +389,10 @@ fun AtomicExp_PROD_8_ACT (EQ, SR, Exp, LCB, RCB, Name, EQ_SPAN : (Lex.pos * Lex.
fun AtomicExp_PROD_9_ACT (Exp, ValueDecl, KW_in, KW_end, KW_let, Exp_SPAN : (Lex.pos * Lex.pos), ValueDecl_SPAN : (Lex.pos * Lex.pos), KW_in_SPAN : (Lex.pos * Lex.pos), KW_end_SPAN : (Lex.pos * Lex.pos), KW_let_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
(
mark PT.MARKexp (FULL_SPAN, PT.LETRECexp (ValueDecl, Exp)))
fun Field_PROD_1_ACT (EQ, Exp, Name, EQ_SPAN : (Lex.pos * Lex.pos), Exp_SPAN : (Lex.pos * Lex.pos), Name_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
( (Name, SOME Exp))
fun Field_PROD_2_ACT (Name, TILDE, Name_SPAN : (Lex.pos * Lex.pos), TILDE_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
( (Name, NONE))
fun ValueDecl_PROD_1_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)) =
( Name1, Name2, Exp)
fun Lit_PROD_1_ACT (Int, Int_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) =
......@@ -1251,17 +1255,13 @@ and AtomicExp_NT (strm) = let
fun AtomicExp_PROD_4 (strm) = let
val (WITH_RES, WITH_SPAN, strm') = matchWITH(strm)
val (LCB_RES, LCB_SPAN, strm') = matchLCB(strm')
val (Name_RES, Name_SPAN, strm') = Name_NT(strm')
val (EQ_RES, EQ_SPAN, strm') = matchEQ(strm')
val (Exp_RES, Exp_SPAN, strm') = Exp_NT(strm')
val (Field_RES, Field_SPAN, strm') = Field_NT(strm')
fun AtomicExp_PROD_4_SUBRULE_1_NT (strm) = let
val (COMMA_RES, COMMA_SPAN, strm') = matchCOMMA(strm)
val (Name_RES, Name_SPAN, strm') = Name_NT(strm')
val (EQ_RES, EQ_SPAN, strm') = matchEQ(strm')
val (Exp_RES, Exp_SPAN, strm') = Exp_NT(strm')
val FULL_SPAN = (#1(COMMA_SPAN), #2(Exp_SPAN))
val (Field_RES, Field_SPAN, strm') = Field_NT(strm')
val FULL_SPAN = (#1(COMMA_SPAN), #2(Field_SPAN))
in
((Name_RES, Exp_RES), FULL_SPAN, strm')
((Field_RES), FULL_SPAN, strm')
end
fun AtomicExp_PROD_4_SUBRULE_1_PRED (strm) = (case (lex(strm))
of (Tok.COMMA, _, strm') => true
......@@ -1271,7 +1271,7 @@ and AtomicExp_NT (strm) = let
val (RCB_RES, RCB_SPAN, strm') = matchRCB(strm')
val FULL_SPAN = (#1(WITH_SPAN), #2(RCB_SPAN))
in
(UserCode.AtomicExp_PROD_4_ACT (EQ_RES, SR_RES, Exp_RES, LCB_RES, RCB_RES, Name_RES, WITH_RES, EQ_SPAN : (Lex.pos * Lex.pos), SR_SPAN : (Lex.pos * Lex.pos), Exp_SPAN : (Lex.pos * Lex.pos), LCB_SPAN : (Lex.pos * Lex.pos), RCB_SPAN : (Lex.pos * Lex.pos), Name_SPAN : (Lex.pos * Lex.pos), WITH_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)),
(UserCode.AtomicExp_PROD_4_ACT (SR_RES, LCB_RES, RCB_RES, WITH_RES, Field_RES, SR_SPAN : (Lex.pos * Lex.pos), LCB_SPAN : (Lex.pos * Lex.pos), RCB_SPAN : (Lex.pos * Lex.pos), WITH_SPAN : (Lex.pos * Lex.pos), Field_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)),
FULL_SPAN, strm')
end
fun AtomicExp_PROD_5 (strm) = let
......@@ -1387,6 +1387,31 @@ and ValueDecl_NT (strm) = let
(UserCode.ValueDecl_PROD_1_ACT (EQ_RES, Exp_RES, Name1_RES, Name2_RES, KW_val_RES, 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)),
FULL_SPAN, strm')
end
and Field_NT (strm) = let
fun Field_PROD_1 (strm) = let
val (Name_RES, Name_SPAN, strm') = Name_NT(strm)
val (EQ_RES, EQ_SPAN, strm') = matchEQ(strm')
val (Exp_RES, Exp_SPAN, strm') = Exp_NT(strm')
val FULL_SPAN = (#1(Name_SPAN), #2(Exp_SPAN))
in
(UserCode.Field_PROD_1_ACT (EQ_RES, Exp_RES, Name_RES, EQ_SPAN : (Lex.pos * Lex.pos), Exp_SPAN : (Lex.pos * Lex.pos), Name_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)),
FULL_SPAN, strm')
end
fun Field_PROD_2 (strm) = let
val (TILDE_RES, TILDE_SPAN, strm') = matchTILDE(strm)
val (Name_RES, Name_SPAN, strm') = Name_NT(strm')
val FULL_SPAN = (#1(TILDE_SPAN), #2(Name_SPAN))
in
(UserCode.Field_PROD_2_ACT (Name_RES, TILDE_RES, Name_SPAN : (Lex.pos * Lex.pos), TILDE_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)),
FULL_SPAN, strm')
end
in
(case (lex(strm))
of (Tok.TILDE, _, strm') => Field_PROD_2(strm)
| (Tok.ID(_), _, strm') => Field_PROD_1(strm)
| _ => fail()
(* end case *))
end
and SelectExp_NT (strm) = let
val (ApplyExp_RES, ApplyExp_SPAN, strm') = ApplyExp_NT(strm)
fun SelectExp_PROD_1_SUBRULE_1_NT (strm) = let
......
......@@ -461,12 +461,15 @@ fun typeInferencePass (errStrm, ti : TI.type_info, ast) = let
val fieldsVar' = newFlow fieldsVar
val env = E.meetBoolean (BD.meetVarImpliesVar (bvar fieldsVar', bvar fieldsVar), env)
val env = E.pushType (false, fieldsVar', env)
fun pushOutField ((fid,e), (nts, env)) =
fun pushOutField ((fid,eOpt), (nts, env)) =
let
(*val _ = TextIO.print ("**** rec update: pushing field " ^ SymbolTable.getString(!SymbolTables.fieldTable, fid) ^ ".\n")*)
val env = infExp (st,env) e
val bVar = BD.freshBVar ()
val env = E.meetBoolean (BD.meetVarOne bVar, env)
val env = case eOpt of
SOME e => E.meetBoolean (BD.meetVarOne bVar,
infExp (st,env) e)
| NONE => E.meetBoolean (BD.meetVarZero bVar,
E.pushTop env)
in
((bVar, fid) :: nts, env)
end
......
......@@ -82,6 +82,23 @@ end = struct
handle SymbolAlreadyDefined =>
FI.lookup (!ST.fieldTable, atom)
(*check if a field name is used several time in record constructions or
record updates*)
fun checkDupFields span fs =
let
fun gather ((f,_),set) =
if SymSet.member (set,f) then
(Error.errorAt
(errStrm,
span,
["field ", FI.getString (!ST.fieldTable, f),
" cannot be updated more than once"]); set)
else
SymSet.add (set,f)
in
(List.foldl gather SymSet.empty fs; fs)
end
(* define a first traversal that registers:
* - type synonyms
* - datatype declarations including constructors
......@@ -174,8 +191,8 @@ end = struct
| PT.BITty i => AST.BITty i
| PT.NAMEDty n => AST.NAMEDty (useType (s,n))
| PT.RECORDty fs =>
AST.RECORDty
(List.map (fn (f,t) => (newField (s,f), convTy s t)) fs)
AST.RECORDty (checkDupFields s
(List.map (fn (f,t) => (newField (s,f), convTy s t)) fs))
and convExp s e =
case e of
......@@ -200,12 +217,15 @@ end = struct
| PT.APPLYexp (e1,es) =>
AST.APPLYexp (convExp s e1, map (convExp s) es)
| PT.RECORDexp l =>
AST.RECORDexp
(List.map (fn (f,e) => (newField (s,f), convExp s e)) l)
AST.RECORDexp (checkDupFields s
(List.map (fn (f,e) => (newField (s,f), convExp s e)) l))
| PT.SELECTexp f => AST.SELECTexp (useField (s,f))
| PT.UPDATEexp fs =>
AST.UPDATEexp
(List.map (fn (f,e) => (newField (s,f), convExp s e)) fs)
AST.UPDATEexp (checkDupFields s
(List.map (fn (f,eOpt) => (newField (s,f),
case eOpt of
SOME e => SOME (convExp s e)
| NONE => NONE)) fs))
| PT.LITexp lit => AST.LITexp (convLit s lit)
| PT.SEQexp l => AST.SEQexp (convSeqexp s l)
| PT.IDexp v => AST.IDexp (useVar (s,v))
......
......@@ -1307,6 +1307,8 @@ end = struct
handle (BD.Unsatisfiable bVar) =>
flowError (bVar, NONE, [env,env1,env2])
val bFun = BD.meet (bFunFlow, bFun)
handle (BD.Unsatisfiable bVar) =>
flowError (bVar, NONE, [env,env1,env2])
val (scs,state) = env
val env = (scs,Scope.setSize sCons (Scope.setFlow bFun state))
......
......@@ -33,13 +33,13 @@ val set-addrsz = update@{addrsz='1'}
val failOver first second = do
update@{tab=second};
r <- first;
update@{tab=42};
update@{~tab};
return r
end
val continue = do
t <- query$tab;
update@{tab=42};
update@{~tab};
r <- t;
update@{tab=t};
return r
......@@ -52,8 +52,6 @@ val /f2 [] = continue
val /f3 [] = continue
val /f3_noCont = do update @{tab=return MOV}; /f3 end
val /legacy-p [0x2e] = do clear-rex; set-CS end
val /legacy-p [0x36] = do clear-rex; set-SS end
val /legacy-p [0x3e] = do clear-rex; set-DS end
......@@ -107,7 +105,7 @@ val p/f3/f2 [0xf2] = do set-repne; p/f3/f2 end
val p/f3/f2 [0xf3] = do set-rep; p/f2/f3 end
val p/f3/f2 [/legacy-p] = p/f3/f2
val p/f3/f2 [/rex-p] = p/f3/f2
val p/f3/f2 [] = failOver /f2 /f3_noCont
val p/f3/f2 [] = failOver /f2 (failOver /f3 /)
val p/66/f2 [0x66] = do set-opndsz; p/f2/66 end
val p/66/f2 [0xf2] = do set-repne; p/66/f2 end
......
......@@ -55,23 +55,21 @@ val set-addrsz = update@{addrsz='1'}
# in sequence. The first function takes two arguments and runs the first
# one until it calls 'continue', at which point the second decoder is run.
val giveNop = return (ARITY0 {tag=NOP})
val after fst snd = do
update@{tab=snd};
r <- fst;
# make the type checker happy
update@{tab=giveNop};
update@{~tab};
return r
end
val continue = do
t <- query$tab;
# make the type checker happy
update@{tab=giveNop};
update@{~tab};
# make the type checker happy
r <- t;
update@{tab=t};
update@{~tab};
return r
end
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment