Commit 81cb1361 authored by László Domoszlai's avatar László Domoszlai

- handle oversaturated inlineable applications

- fix bug in let binding ordering
- fix pattern matching when embedded case expressions are involved

git-svn-id: https://svn.cs.ru.nl/repos/clean-sapl/branches/hierarchical@408 cb785ff4-4565-4a15-8565-04c4fcf96d79
parent c6fd054a
......@@ -12,7 +12,7 @@ from Data.Map import :: Map
}
:: ConstructorDef = { index :: !Int
, singleton :: !Bool
, nr_cons :: !Int
, nr_args :: !Int // for efficiency
, args :: [SaplVar]
}
......
......@@ -26,15 +26,11 @@ defaultState = {ps_level = 0, ps_constructors = newMap, ps_functions = newMap, p
addConstructor name def :== \s -> Ok (name, {s & ps_constructors = put (unpackVar name) def s.ps_constructors})
addConstructors conses=:[SaplConstructor name idx as]
= \s -> Ok (conses, {s & ps_constructors = put (unpackVar name) def s.ps_constructors})
where
def = {index = idx, singleton = True, nr_args = length as, args = as}
addConstructors conses = \s -> Ok (conses, {s & ps_constructors = foldl adddef s.ps_constructors conses})
where
nr_cons = length conses
adddef m (SaplConstructor name idx as)
= put (unpackVar name) {index = idx, singleton = False, nr_args = length as, args = as} m
= put (unpackVar name) {index = idx, nr_cons = nr_cons, nr_args = length as, args = as} m
factor [TIdentifier name:ts] = getLevel >>= \level = returnS (Just (SVar (NormalVar name level)), ts)
factor [TLit lit:ts] = returnS (Just (SLit lit), ts)
......@@ -194,7 +190,7 @@ constr [TTypeDef, TIdentifier name, TAssignmentOp, TOpenBracket: ts] =
getLevel
>>= \level = args_record ts
>>= \(as, ts) = case hd ts of
TCloseBracket = addConstructor (NormalVar name level) {index = 0, singleton = True, nr_args = length as, args = as} >>= \tname = returnS (FTRecord tname as, tl ts)
TCloseBracket = addConstructor (NormalVar name level) {index = 0, nr_cons = 1, nr_args = length as, args = as} >>= \tname = returnS (FTRecord tname as, tl ts)
= returnE (ts, "Missing close parenthesis3")
// ADT
......@@ -270,4 +266,3 @@ where
mergeMaps m1 m2 = putList (toList m2) m1
mergeParserStates pst1 Nothing = pst1
......@@ -49,5 +49,6 @@ unpackVar :: !SaplVar -> String
unpackBindVar :: !SaplLetDef -> SaplVar
unpackConsName :: !SaplPattern -> Maybe String
isConsPattern :: !SaplPattern -> Bool
isConsPattern :: !SaplPattern -> Bool
isDefaultPattern :: !SaplPattern -> Bool
......@@ -56,3 +56,6 @@ isConsPattern :: !SaplPattern -> Bool
isConsPattern (PCons _ _) = True
isConsPattern _ = False
isDefaultPattern :: !SaplPattern -> Bool
isDefaultPattern PDefault = True
isDefaultPattern _ = False
This diff is collapsed.
implementation module Sapl.Transform.Let
import StdList, StdFunc, StdTuple
import StdList, StdFunc, StdTuple, StdBool
import Sapl.SaplStruct
from Data.Set import qualified newSet, fromList, toList, member, difference, insert, filter, delete, null
......@@ -21,7 +21,7 @@ genGraph binds defs = foldl (\s (SaplLetDef bv body) -> gen binds bv s body) ('D
where
gen vs bv s (SApplication f as) = foldl (gen vs bv) s [SVar f:as]
gen vs bv (es,is) (SVar v)
| 'Data.Set'.member v vs = ('Data.Set'.insert (bv, v) es, 'Data.Set'.delete v is)
| 'Data.Set'.member v vs && v <> bv = ('Data.Set'.insert (bv, v) es, 'Data.Set'.delete v is)
gen _ _ s _ = s
// Kahn, Arthur B. (1962), "Topological sorting of large networks"
......
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