lincat can now be just Str

This commit is contained in:
aarne
2008-03-09 12:17:42 +00:00
parent db0456d993
commit 72891176a7
3 changed files with 9 additions and 5 deletions

View File

@@ -311,13 +311,15 @@ checkIfStrType st typ = case typ of
checkIfLinType :: SourceGrammar -> Type -> Check Type checkIfLinType :: SourceGrammar -> Type -> Check Type
checkIfLinType st typ0 = do checkIfLinType st typ0 = do
typ <- computeLType st typ0 typ <- computeLType st typ0
{- ---- should check that not fun type
case typ of case typ of
RecType r -> do RecType r -> do
let (lins,ihs) = partition (isLinLabel .fst) r let (lins,ihs) = partition (isLinLabel .fst) r
--- checkErr $ checkUnique $ map fst r --- checkErr $ checkUnique $ map fst r
mapM_ checkInh ihs mapM_ checkInh ihs
mapM_ checkLin lins mapM_ checkLin lins
_ -> prtFail "a linearization type must be a record type instead of" typ _ -> prtFail "a linearization type cannot be" typ
-}
return typ return typ
where where
@@ -1037,7 +1039,8 @@ linTypeOfType cnc m typ = do
val <- lookLin mc val <- lookLin mc
let vars = mkRecType varLabel $ replicate n typeStr let vars = mkRecType varLabel $ replicate n typeStr
symb = argIdent n cat i symb = argIdent n cat i
rec <- checkErr $ errIn ("extending" +++ prt vars +++ "with" +++ prt val) $ rec <- if n==0 then return val else
checkErr $ errIn ("extending" +++ prt vars +++ "with" +++ prt val) $
plusRecType vars val plusRecType vars val
return (symb,rec) return (symb,rec)
lookLin (_,c) = checks [ --- rather: update with defLinType ? lookLin (_,c) = checks [ --- rather: update with defLinType ?

View File

@@ -440,8 +440,8 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
Just vs -> (ty,[t | Just vs -> (ty,[t |
(t,_) <- sortBy (\x y -> compare (snd x) (snd y)) (t,_) <- sortBy (\x y -> compare (snd x) (snd y))
(Map.assocs vs)]) (Map.assocs vs)])
_ -> error $ A.prt ty _ -> error $ "doVar1" +++ A.prt ty
_ -> error $ A.prt tr _ -> error $ "doVar2" +++ A.prt tr +++ show (cat,lab) ---- debug
updateSTM ((tyvs, (tr', tr)):) updateSTM ((tyvs, (tr', tr)):)
return tr' return tr'
_ -> GM.composOp doVar tr _ -> GM.composOp doVar tr

View File

@@ -247,7 +247,8 @@ mkLinDefault :: SourceGrammar -> Type -> Err Term
mkLinDefault gr typ = do mkLinDefault gr typ = do
case unComputed typ of case unComputed typ of
RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign) RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign)
_ -> prtBad "linearization type must be a record type, not" typ _ -> liftM (Abs strVar) $ mkDefField typ
---- _ -> prtBad "linearization type must be a record type, not" typ
where where
mkDefField typ = case unComputed typ of mkDefField typ = case unComputed typ of
Table p t -> do Table p t -> do