@@ -125,15 +125,17 @@ checkDefs ctxt (con@(n, DConstructor _ _ _) : xs)
125 return xs'
125 return xs'
126checkDefs ctxt ((n, DFun n' args exp) : xs)
126checkDefs ctxt ((n, DFun n' args exp) : xs)
127 = do let sexp = evalState (simplify True exp) (ctxt, 0)
127 = do let sexp = evalState (simplify True exp) (ctxt, 0)
128− (exp', locs) <- runStateT (scopecheck ctxt (zip args [0..]) sexp) (length args)
128+ (exp', locs) <- runStateT (scopecheck n ctxt (zip args [0..]) sexp) (length args)
129 xs' <- checkDefs ctxt xs
129 xs' <- checkDefs ctxt xs
130 return ((n, SFun n' args ((locs + 1) - length args) exp') : xs')
130 return ((n, SFun n' args ((locs + 1) - length args) exp') : xs')
132lvar v = do i <- get
132lvar v = do i <- get
133 put (max i v)
133 put (max i v)
135−scopecheck :: DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp
135+scopecheck :: Name -> DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp
136−scopecheck ctxt envTop tm = sc envTop tm where
136+scopecheck fn ctxt envTop tm = sc envTop tm where
137+ failsc err = fail $ "Codegen error in " ++ show fn ++ ":" ++ err
137 sc env (SV (Glob n)) =
139 sc env (SV (Glob n)) =
138 case lookup n (reverse env) of -- most recent first
140 case lookup n (reverse env) of -- most recent first
139 Just i -> do lvar i; return (SV (Loc i))
141 Just i -> do lvar i; return (SV (Loc i))
@@ -141,20 +143,20 @@ scopecheck ctxt envTop tm = sc envTop tm where
141 Just (DConstructor _ i ar) ->
143 Just (DConstructor _ i ar) ->
142 if True -- ar == 0
144 if True -- ar == 0
143 then return (SCon i n [])
145 then return (SCon i n [])
144− else fail $ "Codegen error: Constructor " ++ show n ++
146+ else failsc $ "Constructor " ++ show n ++
145 " has arity " ++ show ar
147 " has arity " ++ show ar
146 Just _ -> return (SV (Glob n))
148 Just _ -> return (SV (Glob n))
147− Nothing -> fail $ "Codegen error: No such variable " ++ show n
149+ Nothing -> failsc $ "No such variable " ++ show n
148 sc env (SApp tc f args)
150 sc env (SApp tc f args)
149 = do args' <- mapM (scVar env) args
151 = do args' <- mapM (scVar env) args
150 case lookupCtxtExact f ctxt of
152 case lookupCtxtExact f ctxt of
151 Just (DConstructor n tag ar) ->
153 Just (DConstructor n tag ar) ->
152 if True -- (ar == length args)
154 if True -- (ar == length args)
153 then return $ SCon tag n args'
155 then return $ SCon tag n args'
154− else fail $ "Codegen error: Constructor " ++ show f ++
156+ else failsc $ "Constructor " ++ show f ++
155 " has arity " ++ show ar
157 " has arity " ++ show ar
156 Just _ -> return $ SApp tc f args'
158 Just _ -> return $ SApp tc f args'
157− Nothing -> fail $ "Codegen error: No such variable " ++ show f
159+ Nothing -> failsc $ "No such variable " ++ show f
158 sc env (SForeign l ty f args)
160 sc env (SForeign l ty f args)
159 = do args' <- mapM (\ (t, a) -> do a' <- scVar env a
161 = do args' <- mapM (\ (t, a) -> do a' <- scVar env a
160 return (t, a')) args
162 return (t, a')) args
@@ -165,9 +167,9 @@ scopecheck ctxt envTop tm = sc envTop tm where
165 Just (DConstructor n tag ar) ->
167 Just (DConstructor n tag ar) ->
166 if True -- (ar == length args)
168 if True -- (ar == length args)
167 then return $ SCon tag n args'
169 then return $ SCon tag n args'
168− else fail $ "Codegen error: Constructor " ++ show f ++
170+ else failsc $ "Constructor " ++ show f ++
169− " has arity " ++ show ar
171+ " has arity " ++ show ar
170− _ -> fail $ "Codegen error: No such constructor " ++ show f
172+ _ -> failsc $ "No such constructor " ++ show f
171 sc env (SProj e i)
173 sc env (SProj e i)
172 = do e' <- scVar env e
174 = do e' <- scVar env e
173 return (SProj e' i)
175 return (SProj e' i)
@@ -200,9 +202,9 @@ scopecheck ctxt envTop tm = sc envTop tm where
200 Just i -> do lvar i; return (Loc i)
202 Just i -> do lvar i; return (Loc i)
201 Nothing -> case lookupCtxtExact n ctxt of
203 Nothing -> case lookupCtxtExact n ctxt of
202 Just (DConstructor _ i ar) ->
204 Just (DConstructor _ i ar) ->
203− fail $ "Codegen error : can't pass constructor here"
205+ failsc $ "can't pass constructor here"
204 Just _ -> return (Glob n)
206 Just _ -> return (Glob n)
205− Nothing -> fail $ "Codegen error: No such variable " ++ show n ++
207+ Nothing -> failsc $ "No such variable " ++ show n ++
206 " in " ++ show tm ++ " " ++ show envTop
208 " in " ++ show tm ++ " " ++ show envTop
207 scVar _ x = return x
209 scVar _ x = return x
@@ -212,9 +214,9 @@ scopecheck ctxt envTop tm = sc envTop tm where
212 Just (DConstructor _ i ar) ->
214 Just (DConstructor _ i ar) ->
213 if True -- (length args == ar)
215 if True -- (length args == ar)
214 then return i
216 then return i
215− else fail $ "Codegen error: Constructor " ++ show n ++
217+ else failsc $ "Constructor " ++ show n ++
216 " has arity " ++ show ar
218 " has arity " ++ show ar
217− _ -> fail $ "Codegen error: No constructor " ++ show n
219+ _ -> failsc $ "No constructor " ++ show n
218 e' <- sc env' e
220 e' <- sc env' e
219 return (SConCase (length env) tag n args e')
221 return (SConCase (length env) tag n args e')
220 scalt env (SConstCase c e) = do e' <- sc env e
222 scalt env (SConstCase c e) = do e' <- sc env e