Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/plambda/chkplexp.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/plambda/chkplexp.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 2037, Mon Aug 21 20:40:35 2006 UTC revision 2038, Mon Aug 21 23:07:07 2006 UTC
# Line 115  Line 115 
115  fun ltAppChk (lt, ts, kenv) : LT.lty =  fun ltAppChk (lt, ts, kenv) : LT.lty =
116    (case lt_inst_chk(lt, ts, kenv)    (case lt_inst_chk(lt, ts, kenv)
117      of [b] => b      of [b] => b
118       | _ => bug "unexpected ase in ltAppChk")       | _ => bug "unexpected arg in ltAppChk")
119    
120  (** utility functions for type checking *)  (** utility functions for type checking *)
121  fun ltTyApp le s (lt, ts, kenv) =  fun ltTyApp le s (lt, ts, kenv) =
# Line 216  Line 216 
216        fun loop le =        fun loop le =
217         (case le         (case le
218           of VAR v =>           of VAR v =>
219                (let val lty = LT.ltLookup(venv, v, d)                (LT.ltLookup(venv, v, d)
                 in ltyChk kenv lty; lty  (* no -- move this out and kcheck result *)  
                end  
220                 handle LT.ltUnbound =>                 handle LT.ltUnbound =>
221                  (say ("** Lvar ** " ^ (LV.lvarName(v)) ^ " is unbound *** \n");                  (say ("** Lvar ** " ^ (LV.lvarName(v)) ^ " is unbound *** \n");
222                   bug "unexpected lambda code in checkLty"))                   bug "unexpected lambda code in checkLty"))
# Line 228  Line 226 
226            | STRING _ => ltString            | STRING _ => ltString
227            | PRIM(p, t, ts) =>            | PRIM(p, t, ts) =>
228               (* kind check t and ts *)               (* kind check t and ts *)
229                (ltyChkenv t; map (tycChk kenv) ts;                ((* ltyChkenv t; map (tycChk kenv) ts; *)
230                 ltTyApp le "PRIM" (t, ts, kenv))                 ltTyApp le "PRIM" (t, ts, kenv))
231    
232            | FN(v, t, e1) =>            | FN(v, t, e1) =>
233                let val _ = ltyChkenv t (* kind check *)                let val _ = ltyChkenv t (* kind check bound variable type *)
234                    val venv' = LT.ltInsert(venv, v, t, d)                    val venv' = LT.ltInsert(venv, v, t, d)
235                    val res = check (kenv, venv', d) e1                    val res = check (kenv, venv', d) e1
236    (*                  val _ = ltyChkenv res *)
237                 in ltFun(t, res) (* handle both functions and functors *)                 in ltFun(t, res) (* handle both functions and functors *)
238                end                end
239    
240            | FIX(vs, ts, es, eb) =>            | FIX(vs, ts, es, eb) =>
241                let val _ = map ltyChkenv ts  (* kind check *)                let val _ = map ltyChkenv ts  (* kind check bound variable types *)
242                    fun h (env, v::r, x::z) = h(LT.ltInsert(env, v, x, d), r, z)                    fun h (env, v::r, x::z) = h(LT.ltInsert(env, v, x, d), r, z)
243                      | h (env, [], []) = env                      | h (env, [], []) = env
244                      | h _ = bug "unexpected FIX bindings in checkLty."                      | h _ = bug "unexpected FIX bindings in checkLty."
245                    val venv' = h(venv, vs, ts)                    val venv' = h(venv, vs, ts)
246    
247                    val nts = map (check (kenv, venv', d)) es                    val nts = map (check (kenv, venv', d)) es
248    (*                   val _ = map ltyChkenv nts *)
249                    val _ = app2(ltMatch le "FIX1", ts, nts)                    val _ = app2(ltMatch le "FIX1", ts, nts)
250    
251                 in check (kenv, venv', d) eb                 in check (kenv, venv', d) eb
252                end                end
253    
254            | APP(e1, e2) => ltFnApp le "APP" (loop e1, loop e2)            | APP(e1, e2) =>
255                  let val top = loop e1
256                      val targ = loop e2
257                  in (* ltyChkenv top; ltyChkenv targ; *)
258                     ltFnApp le "APP" (top, targ)
259                  end
260    
261            | LET(v, e1, e2) =>            | LET(v, e1, e2) =>
262                let val venv' = LT.ltInsert(venv, v, loop e1, d)                let val t1 = loop e1
263    (*                  val _ = ltyChkenv t1 *)
264                      val venv' = LT.ltInsert(venv, v, t1, d)
265                 in check (kenv, venv', d) e2                 in check (kenv, venv', d) e2
266                end                end
267    
268            | TFN(ks, e) =>            | TFN(ks, e) =>
269                let val kenv' = LT.tkInsert(kenv, ks)                let val kenv' = LT.tkInsert(kenv, ks)
270                    val lt = check (kenv', venv, DI.next d) e                    val lt = check (kenv', venv, DI.next d) e
271    (*                  val _ = ltyChkenv lt *)
272                 in LT.ltc_poly(ks, [lt])                 in LT.ltc_poly(ks, [lt])
273                end                end
274    
275            | TAPP(e, ts) => ltTyApp le "TAPP" (loop e, ts, kenv)            | TAPP(e, ts) =>
276                  let val lt = loop e
277    (*                  val _ = ltyChkenv lt *)
278                  in  ltTyApp le "TAPP" (lt, ts, kenv)
279                  end
280    
281            | GENOP(dict, p, t, ts) =>            | GENOP(dict, p, t, ts) =>
282                ((* should type check dict also *)                ((* should type check dict also *)
283                 ltTyApp le "GENOP" (t, ts, kenv))                 ltTyApp le "GENOP" (t, ts, kenv))
# Line 277  Line 290 
290    
291            | CON((_, rep, lt), ts, e) =>            | CON((_, rep, lt), ts, e) =>
292                let val t1 = ltTyApp le "CON" (lt, ts, kenv)                let val t1 = ltTyApp le "CON" (lt, ts, kenv)
293    (*                  val _ = ltyChkenv t1 *)
294                    val t2 = loop e                    val t2 = loop e
295    (*                  val _ = ltyChkenv t2 *)
296                 in ltFnApp le "CON-A" (t1, t2)                 in ltFnApp le "CON-A" (t1, t2)
297                end                end
298  (*  (*

Legend:
Removed from v.2037  
changed lines
  Added in v.2038

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0