We planned to upgrade GitLab and Mattermost to the latest version this Friday morning. Expect some downtime!

Commit 9f0a3584 authored by Laszlo Domoszlai's avatar Laszlo Domoszlai

compiler to the new SAPL

parent 484fb866
......@@ -47,8 +47,13 @@ propBody ps flavour sd body = walk sd body
where
walk sd t=:(SVar var) = (insert (unpackVar var) sd, t)
walk sd t=:(SApplication var args)
// We can skip the new args, cannot contain let definitions...
// We can skip the new expr, cannot contain let definitions...
walk sd t=:(SSelect expr idx)
# (sd, _) = walk sd expr
= (sd, t)
// We can skip the new args, cannot contain let definitions...
walk sd t=:(SApplication (SVar var) args)
# nsds = map fst (map (walk newSet) strictArgs)
= (unions [sd:nsds], t)
where
......@@ -57,16 +62,17 @@ where
checkArg (arg, i) = isStrictArg ps flavour varName nr_args i
strictArgs = map fst (filter checkArg (zip2 args [0..]))
walk sd (SIf c l r)
# (sdl, nl) = walk newSet l
# (sdr, nr) = walk newSet r
# (sdc, nc) = walk sd c
= (union sdc (intersection sdl sdr), SIf nc nl nr)
// We can skip the new expr, cannot contain let definitions...
// Args cannot be checked, we do not know the function defiition...
walk sd t=:(SApplication expr args)
// expr is always strict
# (sd, _) = walk sd expr
= (sd, t)
walk sd (SSelect p cases)
walk sd (SCase p cases)
# (sdp, np) = walk sd p
# (sdcs, ncases) = unzip (map walkcase cases)
= (union sdp (intersections sdcs), SSelect np ncases)
= (union sdp (intersections sdcs), SCase np ncases)
where
walkcase (p, c)
# (sd, nc) = walk newSet c
......@@ -89,7 +95,7 @@ where
where
vn = unpackVar (unpackBindVar bnd)
// Delete itself, it dosn't need any more
// Delete itself, it doesn't need any more
walkbnd sd (SaplLetDef (TypedVar (StrictVar vn _) _) body) = delete vn (fst (walk sd body)) // skip new body, it cannot be a let definition
walkbnd sd (SaplLetDef (TypedVar (NormalVar vn _) _) body) = delete vn sd
......
......@@ -49,4 +49,3 @@ parseExpr :: [PosToken] -> MaybeError ErrorMsg (SaplTerm, ParserState)
* @return merged parser state
*/
mergeParserStates :: ParserState (Maybe ParserState) -> ParserState
......@@ -63,98 +63,110 @@ where
addTupleCons _ = returnS Void
factor [TIdentifier name:ts] = getLevel >>= \level = returnS (Just (SVar (NormalVar name level)), ts)
factor [TLit lit:ts] = returnS (Just (SLit lit), ts)
factor [TOpenParenthesis:ts] =
application ts
read_int [TLit (LInt lit):ts] = returnS (Just lit, ts)
read_int ts = returnS (Nothing, ts)
expr [TOpenParenthesis:ts] =
mexpr ts
>>= \(t, ts) = case hd ts of
TCloseParenthesis = returnS (Just t, tl ts)
= returnE (ts, "Missing close parenthesis")
factor ts = returnS (Nothing, ts)
= returnE (ts, "Missing close parenthesisx")
application [TOpenParenthesis:ts] =
application ts
>>= \(t, ts) = case hd ts of
TCloseParenthesis = returnS (t, tl ts)
= returnE (ts, "Missing close parenthesis")
expr [TLit lit:ts] = returnS (Just (SLit lit), ts)
application [TIdentifier name:ts] =
expr [TIdentifier name:ts] =
getLevel
>>= \level = returnS (NormalVar name level)
>>= \t = addTupleCons name
>>= \_ = args_factor ts
>>= \_ = args_expr ts
>>= \(as, ts) = case as of
[] = returnS (SVar t, ts) // !!!
= returnS (SApplication t as, ts)
application [TLit lit:ts] = returnS (SLit lit, ts)
application ts = returnE (ts, "Invalid application")
selectexpr [TIfKeyword:ts] =
arg_adv ts
>>= mandatory "Missing predicate"
>>= \(pred, ts) = arg_adv ts
>>= mandatory "Missing left hand side"
>>= \(lhs, ts) = arg_adv ts
>>= mandatory "Missing right hand side"
>>= \(rhs, ts) = returnS (Just (SIf pred lhs rhs), ts)
selectexpr [TSelectKeyword:ts] =
arg_adv ts
>>= mandatory "Missing select expression"
>>= \(expr, ts) = args_pattern ts
>>= \(ps, ts) = if (isEmpty ps)
(returnE (ts, "Missing select patterns"))
(returnS (Just (SSelect expr ps), ts))
selectexpr ts = returnS (Nothing, ts)
[] = returnS (Just (SVar t), ts)
= returnS (Just (SApplication (SVar t) as), ts)
expr [TSelectKeyword:ts] =
sexpr ts
>>= mandatory "Missing select expression"
>>= \(expr, ts) = read_int ts
>>= mandatory "Missing select index"
>>= \(idx, ts) = args_expr ts
>>= \(as, ts) = case as of
[] = returnS (Just (SSelect expr idx), ts)
= returnS (Just (SApplication (SSelect expr idx) as), ts)
expr ts = returnS (Nothing, ts)
sexpr [TOpenParenthesis:ts] =
mexpr ts
>>= \(t, ts) = case hd ts of
TCloseParenthesis = returnS (Just t, tl ts)
= returnE (ts, "Missing close parenthesisx")
mainexpr ts = selectexpr ts
>>= \(t, ts) = case t of
Just t = returnS (t, ts)
= application ts
sexpr [TLit lit:ts] = returnS (Just (SLit lit), ts)
sexpr [TIdentifier name:ts] =
getLevel
>>= \level = returnS (NormalVar name level)
>>= \t = addTupleCons name
>>= \_ = returnS (Just (SVar t), ts)
sexpr ts = returnS (Nothing, ts)
mexpr ts = expr ts >>= mandatory "Missing expression"
letdefinitions ts = letdef_1 ts []
where
letdef_1 [TIdentifier name, TTypeDef, TIdentifier type, TAssignmentOp:ts] as =
getLevel
>>= \level = application ts
>>= \level = body False ts
>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (NormalVar name level) (Type type)) t:as]
letdef_1 [TIdentifier name, TAssignmentOp:ts] as =
getLevel
>>= \level = application ts
>>= \level = body False ts
>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (NormalVar name level) NoType) t:as]
letdef_1 [TStrictIdentifier name, TTypeDef, TIdentifier type, TAssignmentOp:ts] as =
getLevel
>>= \level = application ts
>>= \level = body False ts
>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (StrictVar name level) (Type type)) t:as]
letdef_1 [TStrictIdentifier name, TAssignmentOp:ts] as =
getLevel
>>= \level = application ts
>>= \level = body False ts
>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (StrictVar name level) NoType) t:as]
letdef_1 ts as = returnE (ts, "Invalid \"let\" definition")
letdef_2 [TColon: ts] as = letdef_1 ts as
letdef_2 ts as = returnS (reverse as, ts)
body [TLetKeyword:ts] =
body simple [TOpenParenthesis:ts] =
body False ts
>>= \(t, ts) = case hd ts of
TCloseParenthesis = returnS (t, tl ts)
= returnE (ts, "Missing close parenthesis")
body simple [TLetKeyword:ts] =
incLevel ts
>>= \ts = letdefinitions ts
>>= \(ds, ts) = case hd ts of
TInKeyword = returnS (tl ts)
= returnE (ts, "Missing \"in\" keyword")
>>= \ts = mainexpr ts
>>= \ts = body False ts
>>= \(t, ts) = returnS (SLet t ds, ts)
>>= decLevel
body simple [TCaseKeyword:ts] =
body True ts
>>= \(expr, ts) = args_pattern ts
>>= \(ps, ts) = if (isEmpty ps)
(returnE (ts, "Missing case patterns"))
(returnS (SCase expr ps, ts))
body [TOpenBracket:ts] = skip ts // ABC code: skip it
body simple [TOpenBracket:ts] = skip ts // ABC code: skip it
where
skip [TCloseBracket:ts] = returnS (SAbortBody, ts)
skip [] = returnE ([], "Missing close bracket in ABC code definition")
skip [t:ts] = skip ts
body ts = mainexpr ts
body simple ts = ((if simple sexpr expr) ts) >>= mandatory "Missing expression"
args_factor ts = args_ factor ts
args_expr ts = args_ sexpr ts
args_pattern ts = args_ arg_pattern ts
args_ f ts = args` ts []
......@@ -166,36 +178,28 @@ where
arg_pattern [TOpenParenthesis:TLit lit:ts] =
case hd ts of
TSelectAssignmentOp = body (tl ts)
TCaseAssignmentOp = body False (tl ts)
= returnE (ts, "Missing select assignment operator")
>>= \(t, ts) = case hd ts of
TCloseParenthesis = returnS (Just (PLit lit, t), tl ts)
= returnE (ts, "Missing close parenthesis")
= returnE (ts, "Missing close parenthesis3")
arg_pattern [TOpenParenthesis:TIdentifier cons:ts] =
incLevel ts
>>= \ts = addTupleCons cons
>>= \_ = args ts
>>= \(as, ts) = case hd ts of
TSelectAssignmentOp = body (tl ts)
TCaseAssignmentOp = body False (tl ts)
= returnE (ts, "Missing select assignment operator")
>>= \(t, ts) = case hd ts of
TCloseParenthesis = returnS (Just (mbCons as, t), tl ts)
= returnE (ts, "Missing close parenthesis")
= returnE (ts, "Missing close parenthesis4")
>>= decLevel
where
mbCons as = if (cons=="_") PDefault (PCons cons as)
arg_pattern ts = returnS (Nothing, ts)
arg_adv [TOpenParenthesis:ts] =
body ts >>= \(t, ts) = returnS (Just t, ts)
>>= \(t, ts) = case hd ts of
TCloseParenthesis = returnS (t, tl ts)
= returnE (ts, "Missing close parenthesis")
arg_adv ts = factor ts
args ts = args_ ts []
where
args_ [TIdentifier name:ts] as = getLevel >>= \level = args_ ts [NormalVar name level:as]
......@@ -258,7 +262,7 @@ func ts = returnE (ts, "Not a function or type definition")
typed_caf name type ts =
getLevel
>>= \level = body ts
>>= \level = body False ts
>>= \(t, ts) = addCAF (NormalVar name level) >>= \tname = returnS (FTCAF (TypedVar tname type) t, ts)
typed_fun name type ts =
......@@ -268,7 +272,7 @@ typed_fun name type ts =
TAssignmentOp = returnS (True, tl ts)
TMacroAssignmentOp = returnS (False, tl ts)
= returnE (ts, "Missing assignment operator")
>>= \(func, ts) = body ts
>>= \(func, ts) = body False ts
>>= \(t, ts) = if func
(addFunction (NormalVar name level) as >>= \tname = returnS (FTFunc (TypedVar tname type) t as, ts))
(addFunction (NormalVar name level) as >>= \tname = returnS (FTMacro (TypedVar tname type) t as, ts))
......@@ -297,7 +301,7 @@ where
parseExpr :: [PosToken] -> MaybeError ErrorMsg (SaplTerm,ParserState)
parseExpr pts
# ts = map (\(PosToken _ _ t) = t) pts
= case (body ts) defaultState of
= case (body False ts) defaultState of
Ok ((fts, _),ps) = Ok (fts,ps)
Error (ts, msg) = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before charachter "+++toString cp)
where
......
......@@ -17,11 +17,10 @@ import Data.Maybe
:: SaplTerm = SLit Literal
| SVar SaplVar
| SApplication SaplVar [SaplTerm]
| SIf SaplTerm SaplTerm SaplTerm
| SSelector SaplTerm
| SSelect SaplTerm [(SaplPattern, SaplTerm)]
| SApplication SaplTerm [SaplTerm]
| SCase SaplTerm [(SaplPattern, SaplTerm)]
| SLet SaplTerm [SaplLetDef]
| SSelect SaplTerm Int
| SAbortBody
:: SaplLetDef = SaplLetDef SaplTypedVar SaplTerm
......@@ -67,6 +66,7 @@ instance unpackVar SaplVar
instance unpackVar SaplTypedVar
unpackBindVar :: !SaplLetDef -> SaplTypedVar
unpackBindExpr :: !SaplLetDef -> SaplTerm
unpackConsName :: !SaplPattern -> Maybe String
toStrictBind :: !SaplLetDef -> SaplLetDef
......
......@@ -86,6 +86,9 @@ where
unpackBindVar :: !SaplLetDef -> SaplTypedVar
unpackBindVar (SaplLetDef typedVar _) = typedVar
unpackBindExpr :: !SaplLetDef -> SaplTerm
unpackBindExpr (SaplLetDef _ expr) = expr
unpackConsName :: !SaplPattern -> Maybe String
unpackConsName (PCons cons _) = Just cons
unpackConsName _ = Nothing
......
......@@ -10,7 +10,7 @@ import StdString, Text.Unicode
| TComment String
| TInlineAnnotation
| TAssignmentOp
| TSelectAssignmentOp
| TCaseAssignmentOp
| TMacroAssignmentOp
| TCAFAssignmentOp
| TLambda
......@@ -22,8 +22,8 @@ import StdString, Text.Unicode
| TCloseBracket
| TTypeDef
| TLit Literal
| TSelectKeyword
| TIfKeyword
| TCaseKeyword
| TSelectKeyword
| TLetKeyword
| TInKeyword
| TEndOfLine
......
......@@ -101,7 +101,7 @@ read_token base line
| matchAt ":==" line start
= rnoarg TMacroAssignmentOp 3
| matchAt "->" line start
= rnoarg TSelectAssignmentOp 2
= rnoarg TCaseAssignmentOp 2
| matchCharAt '\\' line start
= rnoarg TLambda 1
| matchCharAt ',' line start
......@@ -136,8 +136,8 @@ read_token base line
"false" = return (TLit (LBool False), stop)
"True" = return (TLit (LBool True), stop)
"true" = return (TLit (LBool True), stop)
"case" = return (TCaseKeyword, stop)
"select" = return (TSelectKeyword, stop)
"if" = return (TIfKeyword, stop)
"let" = return (TLetKeyword, stop)
"in" = return (TInKeyword, stop)
str = if (str.[0] == '!')
......@@ -225,8 +225,8 @@ where
toString TCloseBracket = "}"
toString TTypeDef = "::"
toString (TLit lit) = toString lit
toString TCaseKeyword = "case"
toString TSelectKeyword = "select"
toString TIfKeyword = "if"
toString TLetKeyword = "let"
toString TInKeyword = "in"
toString TEndOfLine = "\n"
......
This diff is collapsed.
definition module Sapl.Target.JS.Lifting
import Sapl.SaplStruct
// Returns True if a term can be inlined, i.e. no separate statement is needed
inline :: !SaplTerm -> Bool
prepareFun :: !FuncType -> FuncType
prepareExpr :: !SaplTerm -> SaplTerm
implementation module Sapl.Target.JS.Lifting
import StdEnv
import Sapl.SaplStruct
inline :: !SaplTerm -> Bool
inline (SLet _ _) = False
inline (SCase cond [(PLit (LBool true), case1),(PLit (LBool false), case2)]) = inline cond && inline case1 && inline case2
inline (SCase cond [(PLit (LBool false), case1),(PLit (LBool true), case2)]) = inline cond && inline case1 && inline case2
inline (SCase _ _) = False
inline _ = True
prepareFun :: !FuncType -> FuncType
prepareFun (FTFunc name body args) = FTFunc name (prepareExpr body) args
prepareFun (FTCAF name body) = FTCAF name (prepareExpr body)
prepareFun ftype = ftype
:: LiftingState = {varidx :: Int}
prepareExpr :: !SaplTerm -> SaplTerm
prepareExpr t
# (t, st, defs) = walkTerm t {varidx = 1}
= case defs of
[] = t
defs = SLet t defs
walkTerm :: !SaplTerm !LiftingState -> (!SaplTerm, !LiftingState, ![SaplLetDef])
walkTerm (SCase cond patterns) st | not (inline cond)
# (letvar, st) = genVar st
# casevar = SVar (removeTypeInfo letvar)
# (patterns, st, pdefs) = walkPatterns patterns st
# defs = [SaplLetDef letvar cond:pdefs]
= case defs of
[] = (SCase casevar patterns, st, [])
defs = (SLet (SCase casevar patterns) defs, st, [])
where
genVar {varidx} = (TypedVar (StrictVar ("$g"+++toString varidx) 0) (Type "B"), {varidx = varidx + 1})
walkTerm c=:(SCase cond patterns) st
# (cond, st, cdefs) = walkTerm cond st
# (patterns, st, pdefs) = walkPatterns patterns st
# defs = cdefs ++ pdefs
= case defs of
[] = (SCase cond patterns, st, []) // TODO: move to pattern
defs = (SLet (SCase cond patterns) defs, st, [])
// TODO: bindings (insert) strict?
walkTerm (SLet expr bindings) st
# (expr, st, defs) = walkTerm expr st
= case defs of
[] = (SLet expr bindings, st, [])
defs = (SLet expr (bindings ++ defs), st, [])
walkTerm (SSelect expr idx) st
# (expr, st, defs) = walkTerm expr st
= (SSelect expr idx, st, defs)
/*
walkTerm (SApplication sel=:(SSelect sexpr _) args) st
# (letvar, st) = genVar st
# selvar = SVar (removeTypeInfo letvar)
# (args, st, defs) = walkArgs args st
= (SApplication selvar args, st, [SaplLetDef letvar sel:defs])
where
genVar {varidx} = (TypedVar (StrictVar ("$g"+++toString varidx) 0) NoType, {varidx = varidx + 1})
*/
walkTerm (SApplication name args) st
# (args, st, defs) = walkArgs args st
= (SApplication name args, st, defs)
walkTerm t st = (t, st, [])
walkArgs [] st = ([], st, [])
walkArgs [t:ts] st
# (t, st, def) = walkTerm t st
# (ts, st, defs) = walkArgs ts st
= ([t:ts], st, def ++ defs)
walkPatterns [] st = ([], st, [])
walkPatterns [(p, t):ps] st
# (t, st, def) = walkTerm t st
# (ts, st, defs) = walkPatterns ps st
= ([(p, t):ts], st, def ++ defs)
......@@ -3,13 +3,18 @@ implementation module Sapl.Transform.AddSelectors
import Sapl.SaplStruct
import StdBool, StdList
// do not do that for embedded "case"s, fall back may be screwed up
instance addSelectors SaplTerm where
addSelectors (SApplication v ts) = SApplication v (map addSelectors ts)
addSelectors (SIf c t e) = SIf (addSelectors c) (addSelectors t) (addSelectors e)
addSelectors st=:(SSelect t ps=:[(PCons _ vs, SVar x)])
# t` = addSelectors t
| foldr (\v acc -> acc || eqVarByName v x) False vs = SSelector (SSelect t` ps)
| otherwise = SSelect t` ps
addSelectors st=:(SCase t ps=:[(PCons _ vs, SVar x)])
| foldr (\v acc -> acc || eqVarByName v x) False vs
# (idx, _) = foldl (\(idx, cnt) v -> if (eqVarByName x v) (cnt, cnt) (idx, cnt + 1)) (0, 0) vs
= SSelect t idx
| otherwise
= SCase t ps
addSelectors (SLet t lds) = SLet (addSelectors t) (map addSelectors lds)
addSelectors st = st
......
......@@ -19,7 +19,9 @@ where
genGraph :: !(Set SaplVar) ![SaplLetDef] -> (!Set (SaplVar,SaplVar), !Set SaplVar)
genGraph binds defs = foldl (\s (SaplLetDef (TypedVar bv _) body) -> gen binds bv s body) ('Data.Set'.newSet,binds) defs
where
gen vs bv s (SApplication f as) = foldl (gen vs bv) s [SVar f:as]
gen vs bv s (SSelect expr idx) = gen vs bv s expr
gen vs bv s (SApplication (SVar f) as) = foldl (gen vs bv) s [SVar f:as]
gen vs bv s (SApplication expr as) = foldl (gen vs bv) (gen vs bv s expr) as
gen vs bv (es,is) (SVar v)
| 'Data.Set'.member v vs && v <> bv = ('Data.Set'.insert (bv, v) es, 'Data.Set'.delete v is)
gen _ _ s _ = s
......
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