The the bug is repeatable at least on my machine.
If there is a cure for this I would be happy to hear about it as I'll have
to finish this for a course I'm taking.
EiffelSymtable.hs is included
-Sakari
--------------------
ghc -fno-monomorphism-restriction --make parse_test.hs -o parse_test
Chasing modules from: parse_test.hs
Skipping EiffelLexer ( ./EiffelLexer.hs, ./EiffelLexer.o )
Skipping EiffelLayout ( ./EiffelLayout.hs, ./EiffelLayout.o )
Skipping EiffelAST ( ./EiffelAST.hs, ./EiffelAST.o )
Compiling EiffelSymtable ( ./EiffelSymtable.hs, ./EiffelSymtable.o )
ghc-6.4: panic! (the `impossible' happened, GHC version 6.4):
Unify.unifyTauTyLists: mismatched type lists!
Please report it as a compiler bug to [email protected],
or http://sourceforge.net/projects/ghc/.
make: *** [parse_test] Error 1
Compilation exited abnormally with code 2 at Thu Apr 28 16:34:29module EiffelSymtable where
import qualified Data.IntMap as IMap
import qualified Data.Map as Map
import EiffelAST
import Data.List
import Data.Maybe
data Err = ErrNoBind {erruse::Int}
| ErrNoSym {erruse::Int, errdef::Int }
deriving Show
class Valuable a where
val::a -> b
data (Valuable a) => SymDict a = SymDict {idcounter:: Int, itot::IMap.IntMap a}
deriving Show
--
addsym::(Valuable a) => a -> SymDict a -> (SymDict a, Int)
addsym k a = ( SymDict {idcounter = i ,
itot = IMap.insert i k $ itot a }, i)
where i = (idcounter a) + 1
lookupsym::(Valuable a) =>Int -> SymDict a -> Maybe a
lookupsym i a = IMap.lookup i (itot a)
symdict :: (Valuable a) =>SymDict a
symdict = SymDict {idcounter = 0, itot = IMap.empty}
--outermost maybe means that it is possible that a type has not been bound to
--variable
data Symbol = SymbolFun { signature::[DefId] , rtype::Maybe DefId}
| SymbolType { typescopes::IMap.IntMap Scope, anyscope::Scope }
| SymbolVar { vtype::Maybe TypeId }
data SymTable = SymTable { syms::IMap.IntMap Symbol,
binds::Bindings,
dict::SymDict,
symerrs::[Err]
}
type Bindings = IMap.IntMap (Maybe DefId)
type TypeId = Int -- refer to the id of the class in symtable
type UseId = Int -- refer to the usage of a symbol
type DefId = Int -- refer to a definition of a symbol in the symtable
type Use = SymTable -> Either UseId (UseId, DefId)
data Bind = Bind { runBind::Scope -> Use}
data Scope = Scope { defs::[DefId] }
{-
define_member::ASTmember -> SymTable -> SymTable
define_type::ASTclass -> SymTable -> SymTable
-}
--
get_type_scope::DefId -> Symbol -> Scope
get_type_scope i s@(SymbolType _ _) =
maybe (anyscope s) (\c -> Scope $ (defs $�anyscope s) ++ (defs c)) $
IMap.lookup i $ typescopes s
get_type_scope i _ = error "Tried to take typescope from non type symbol"
--match sym ids in scope with i and return corresponding sym id
matchfun::[Maybe TypeId] -> UseId -> Scope -> SymTable -> Maybe DefId
matchfun sig i s t = find f $ defs s
where f a = if is_fun a s
then name_cmp t a i &&�
(maybe (False) (\k -> sig_cmp sig $�map
(\r -> vtype . fromJust $�IMap.lookup
r�$�syms t ) $
signature k) $�IMap.lookup a $ syms t)�
else False
sig_cmp ((Just k):ss) ((Just t):ts) = k == t --othrw. undefined types
cannot bind
sig_cmp _ _ = False
match::UseId -> Scope -> SymTable -> Maybe DefId
match i s t = find f (defs s)
where f a = name_cmp t a i && is_var a t
name_cmp d i j = (val $�fromJust $�lookupsym i $ dict d ) ==
(val $�fromJust $�lookupsym j $ dict d)
is_sym_type st f a = maybe False (\s -> maybe False (\k -> f k) s) $�Map.lookup
a $ syms st
is_var a st = is_sym_type st (\s -> case s of
SymbolVar _ -> True
otherwise -> False) a
is_fun a st = is_sym_type st (\s -> case s of
SymbolFun _ _ -> True
otherwise -> False) a
--sentinel binds for the bottom of the bind tree
bindvar::Int -> Bind
bindvar i = Bind (\s t -> maybe (Left i)
(\k -> Right (i, k) ) $�
match i s t)
bindfun::Int -> [Maybe TypeId] -> Bind
bindfun i sig = Bind (\s t -> maybe (Left i)
(\k -> Right (i, k)) $�
matchfun i sig s t)
--solve_binds
solve_binds::[Bind] -> SymTable -> SymTable
solve_binds []�s = s
solve_binds (b:bs) s = case runBind b c s of
Left u -> r $�s {symerrs = (ErrNoBind
u) : (symerrs s),
binds = IMap.insert
(u, Nothing) $
binds s}
Right u -> r $ s {binds = IMap.insert
u $ binds s}
where c = Scope []
r s = solve_binds bs s
--add scope in which to bind
bind_scope::Scope -> Bind -> Bind
bind_scope s b = Bind w
where w = \t s' -> case runBind b s t of
Left i -> runBind b s' t
Right t' -> Right t'
--bind in the scope of the type of expression tagged with current type
bind_from_expr::ASTexpr -> Maybe TypeId -> Bind -> Bind
bind_from_expr x parent b = Bind w
where w = \ s t -> case runBind b s t of
Left i -> maybe (Left i) (\p -> w' i p s
t) $
solve_type x t
Right u -> Right u
w' i p s t = maybe (Left i)
(\e -> runBind b e t) $ get_type_scope parent p
--returns the sym id of the type of expression
solve_type::ASTexpr -> SymTable -> Maybe TypeId
solve_type (ASTexprGroup x) t = solve_type x t
solve_type (ASTexprApp f x) t = get_type f t
solve_type (ASTexprId i) t = get_type i t
solve_type (ASTexprIntLit k ) t = error "todo: literal solve type"
--returns the sym id of the type of i
get_type::UseId -> SymTable -> Maybe TypeId
get_type i t = do
j <- IMap.lookup i $ binds t
k <- IMap.lookup j $ syms t
let w f@(SymbolFun a b) = do
a <- rtype f
b <- IMap.lookup a $ syms t
vtype b
w f@(SymbolVar a) = vtype f
w _ = error "Tried to get type of a type"
w k
_______________________________________________
Glasgow-haskell-bugs mailing list
[email protected]
http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs
