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