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 2032, Fri Aug 18 21:19:55 2006 UTC revision 2033, Fri Aug 18 22:58:46 2006 UTC
# Line 107  Line 107 
107     else LT.ltd_pfct lt) handle _ => raise LtyArrow     else LT.ltd_pfct lt) handle _ => raise LtyArrow
108    
109  val lt_inst_chk = LT.lt_inst_chk_gen()  val lt_inst_chk = LT.lt_inst_chk_gen()
110    (* kind checker for ltys *)
111    val ltyChk = LT.ltyChkGen ()
112    
113  fun ltAppChk (lt, ts, kenv) =  fun ltAppChk (lt, ts, kenv) : LT.lty =
114    (case lt_inst_chk(lt, ts, kenv)    (case lt_inst_chk(lt, ts, kenv)
115      of [b] => b      of [b] => b
116       | _ => bug "unexpected ase in ltAppChk")       | _ => bug "unexpected ase in ltAppChk")
# Line 206  Line 208 
208         in ltMatch le s (nt, root); venv         in ltMatch le s (nt, root); venv
209        end        end
210    
   
211  (** check : tkindEnv * ltyEnv * DI.depth -> lexp -> lty *)  (** check : tkindEnv * ltyEnv * DI.depth -> lexp -> lty *)
212  fun check (kenv, venv, d) =  fun check (kenv, venv, d) =
213    let fun loop le =    let val ltyChkenv = ltyChk kenv
214          fun loop le =
215         (case le         (case le
216           of VAR v =>           of VAR v =>
217                (LT.ltLookup(venv, v, d)                (let val lty = LT.ltLookup(venv, v, d)
218                    in ltyChk kenv lty; lty  (* no -- move this out and kcheck result *)
219                   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 220  Line 224 
224            | (INT32 _ | WORD32 _) => LT.ltc_int32            | (INT32 _ | WORD32 _) => LT.ltc_int32
225            | REAL _ => LT.ltc_real            | REAL _ => LT.ltc_real
226            | STRING _ => ltString            | STRING _ => ltString
227            | PRIM(p, t, ts) => ltTyApp le "PRIM" (t, ts, kenv)            | PRIM(p, t, ts) =>
228                 (* kind check t and ts *)
229                  (ltyChkenv t; map ltyChkenv ts;
230                   ltTyApp le "PRIM" (t, ts, kenv))
231    
232            | FN(v, t, e1) =>            | FN(v, t, e1) =>
233                let val venv' = LT.ltInsert(venv, v, t, d)                let val _ = ltyChkenv t (* kind check *)
234                      val venv' = LT.ltInsert(venv, v, t, d)
235                    val res = check (kenv, venv', d) e1                    val res = check (kenv, venv', d) e1
236                 in ltFun(t, res) (* handle both functions and functors *)                 in ltFun(t, res) (* handle both functions and functors *)
237                end                end
238    
239            | FIX(vs, ts, es, eb) =>            | FIX(vs, ts, es, eb) =>
240                let fun h (env, v::r, x::z) = h(LT.ltInsert(env, v, x, d), r, z)                let val _ = map ltyChkenv ts  (* kind check *)
241                      fun h (env, v::r, x::z) = h(LT.ltInsert(env, v, x, d), r, z)
242                      | h (env, [], []) = env                      | h (env, [], []) = env
243                      | h _ = bug "unexpected FIX bindings in checkLty."                      | h _ = bug "unexpected FIX bindings in checkLty."
244                    val venv' = h(venv, vs, ts)                    val venv' = h(venv, vs, ts)
# Line 330  Line 339 
339                    val nt = LT.ltc_tyc ntc                    val nt = LT.ltc_tyc ntc
340                 in (ltMatch le "UNWRAP" (loop e, nt); LT.ltc_tyc t)                 in (ltMatch le "UNWRAP" (loop e, nt); LT.ltc_tyc t)
341                end)                end)
342      in (* wrap loop with kind check of result *)
343         fn x => let val y = loop x in ltyChkenv y; y end
   in loop  
344   end (* end-of-fn-check *)   end (* end-of-fn-check *)
345    
346  in  in
# Line 342  Line 350 
350    
351  end (* toplevel local *)  end (* toplevel local *)
352  end (* structure CheckLty *)  end (* structure CheckLty *)
   

Legend:
Removed from v.2032  
changed lines
  Added in v.2033

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