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 2044, Thu Aug 24 17:45:04 2006 UTC revision 2046, Thu Aug 24 18:28:43 2006 UTC
# Line 4  Line 4 
4  signature CHKPLEXP =  signature CHKPLEXP =
5  sig  sig
6    
7    exception ChkPlexp (* PLambda type check error *)
8    
9  val checkLtyTop : PLambda.lexp * int -> bool  val checkLtyTop : PLambda.lexp * int -> bool
10  val checkLty : PLambda.lexp * PLambdaType.ltyEnv * int -> bool  val checkLty : PLambda.lexp * PLambdaType.ltyEnv * int -> bool
11  val newlam_ref : PLambda.lexp ref  val newlam_ref : PLambda.lexp ref
# Line 21  Line 23 
23        open PLambda        open PLambda
24  in  in
25    
26    exception ChkPlexp (* PLambda type check error *)
27    
28  (*** a hack of printing diagnostic output into a separate file ***)  (*** a hack of printing diagnostic output into a separate file ***)
29  val newlam_ref : PLambda.lexp ref = ref (RECORD[])  val newlam_ref : PLambda.lexp ref = ref (RECORD[])
30  val fname_ref : string ref = ref "yyy"  val fname_ref : string ref = ref "yyy"
# Line 213  Line 217 
217    
218  (** check : tkindEnv * ltyEnv * DI.depth -> lexp -> lty *)  (** check : tkindEnv * ltyEnv * DI.depth -> lexp -> lty *)
219  fun check (kenv, venv, d) =  fun check (kenv, venv, d) =
220    let val ltyChkenv = ltyChk kenv    let fun ltyChkMsg msg lexp kenv lty =
221                      ltyChk kenv lty
222                      handle LT.KindChk kndchkmsg =>
223                             (say ("*** Kind check failure during \
224                                   \ PLambda type check: ");
225                              say (msg);
226                              say ("***\n Term: ");
227                              PPLexp.printLexp lexp;
228                              say ("\n Kind check error: ");
229                              say kndchkmsg;
230                              say ("\n");
231                              raise ChkPlexp)
232        fun loop le =        fun loop le =
233              let fun ltyChkMsgLexp msg kenv lty =
234                        ltyChkMsg msg lexp kenv lty
235                  fun ltyChkenv msg lty = ltyChkMsgLexp msg kenv lty
236              in
237         (case le         (case le
238           of VAR v =>           of VAR v =>
239                (LT.ltLookup(venv, v, d)                (LT.ltLookup(venv, v, d)
240                 handle LT.ltUnbound =>                 handle LT.ltUnbound =>
241                  (say ("** Lvar ** " ^ (LV.lvarName(v)) ^ " is unbound *** \n");                             (say ("** Lvar ** " ^ (LV.lvarName(v))
242                                     ^ " is unbound *** \n");
243                   bug "unexpected lambda code in checkLty"))                   bug "unexpected lambda code in checkLty"))
244            | (INT _ | WORD _) => LT.ltc_int            | (INT _ | WORD _) => LT.ltc_int
245            | (INT32 _ | WORD32 _) => LT.ltc_int32            | (INT32 _ | WORD32 _) => LT.ltc_int32
# Line 231  Line 251 
251                 ltTyApp le "PRIM" (t, ts, kenv))                 ltTyApp le "PRIM" (t, ts, kenv))
252    
253            | FN(v, t, e1) =>            | FN(v, t, e1) =>
254                let val _ = ltyChkenv t (* kind check bound variable type *)                     let val _ = ltyChkenv "FN bound var" t
255                                             (* kind check bound variable type *)
256                    val venv' = LT.ltInsert(venv, v, t, d)                    val venv' = LT.ltInsert(venv, v, t, d)
257                    val res = check (kenv, venv', d) e1                    val res = check (kenv, venv', d) e1
258                    val _ = ltyChkenv res                         val _ = ltyChkenv "FN rng" res
259                 in ltFun(t, res) (* handle both functions and functors *)                 in ltFun(t, res) (* handle both functions and functors *)
260                end                end
261    
262            | FIX(vs, ts, es, eb) =>            | FIX(vs, ts, es, eb) =>
263                let val _ = map ltyChkenv ts  (* kind check bound variable types *)                     let val _ = map (ltyChkenv "FIX bound var") ts
264                                       (* kind check bound variable types *)
265                    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)
266                      | h (env, [], []) = env                      | h (env, [], []) = env
267                      | h _ = bug "unexpected FIX bindings in checkLty."                      | h _ = bug "unexpected FIX bindings in checkLty."
268                    val venv' = h(venv, vs, ts)                    val venv' = h(venv, vs, ts)
269    
270                    val nts = map (check (kenv, venv', d)) es                    val nts = map (check (kenv, venv', d)) es
271                    val _ = map ltyChkenv nts                         val _ = map (ltyChkenv "FIX body types") nts
272                    val _ = app2(ltMatch le "FIX1", ts, nts)                    val _ = app2(ltMatch le "FIX1", ts, nts)
273    
274                 in check (kenv, venv', d) eb                 in check (kenv, venv', d) eb
# Line 261  Line 283 
283    
284            | LET(v, e1, e2) =>            | LET(v, e1, e2) =>
285                let val t1 = loop e1                let val t1 = loop e1
286                    val _ = ltyChkenv t1                    val _ = ltyChkenv "LET definen" t1
287                    val venv' = LT.ltInsert(venv, v, t1, d)                    val venv' = LT.ltInsert(venv, v, t1, d)
288                 in check (kenv, venv', d) e2                    val bodyLty = check (kenv, venv', d) e2
289                      val _ = ltyChkenv "LET body" bodyLty
290                   in bodyLty
291                end                end
292    
293            | TFN(ks, e) =>            | TFN(ks, e) =>
294                let val kenv' = LT.tkInsert(kenv, ks)                let val kenv' = LT.tkInsert(kenv, ks)
295                    val lt = check (kenv', venv, DI.next d) e                    val lt = check (kenv', venv, DI.next d) e
296                    val _ = ltyChk (ks::kenv) lt                    val _ = ltyChkMsgLexp "TFN body" (ks::kenv) lt
297                 in LT.ltc_poly(ks, [lt])                 in LT.ltc_poly(ks, [lt])
298                end                end
299    
300            | TAPP(e, ts) =>            | TAPP(e, ts) =>
301                let val lt = loop e                let val lt = loop e
302                    val _ = map (fn tc => ltyChkenv(LT.ltc_tyc tc)) ts  (* kind check type args *)                    val _ = map (fn tc => ltyChkenv "TAPP args" (LT.ltc_tyc tc)) ts  (* kind check type args *)
303                    val _ = ltyChkenv lt                    val _ = ltyChkenv "TAPP type function " lt
304                in  ltTyApp le "TAPP" (lt, ts, kenv)                in  ltTyApp le "TAPP" (lt, ts, kenv)
305                end                end
306    
307            | GENOP(dict, p, t, ts) =>            | GENOP(dict, p, t, ts) =>
308                ((* should type check dict also *)                ((* should type check dict also *)
309                 (map (fn tc => ltyChkenv(LT.ltc_tyc tc)) ts;                 (map (fn tc => ltyChkenv "GENOP args " (LT.ltc_tyc tc)) ts;
310                  ltTyApp le "GENOP" (t, ts, kenv)))                  ltTyApp le "GENOP" (t, ts, kenv)))
311    
312            | PACK(lt, ts, nts, e) =>            | PACK(lt, ts, nts, e) =>
# Line 293  Line 317 
317    
318            | CON((_, rep, lt), ts, e) =>            | CON((_, rep, lt), ts, e) =>
319                let val t1 = ltTyApp le "CON" (lt, ts, kenv)                let val t1 = ltTyApp le "CON" (lt, ts, kenv)
320                    val _ = ltyChkenv t1                    val _ = ltyChkenv "CON 1 " t1
321                    val t2 = loop e                    val t2 = loop e
322                    val _ = ltyChkenv t2                    val _ = ltyChkenv "CON 2 " t2
323                 in ltFnApp le "CON-A" (t1, t2)                 in ltFnApp le "CON-A" (t1, t2)
324                end                end
325  (*  (*
# Line 310  Line 334 
334    
335            | VECTOR (el, t)  =>            | VECTOR (el, t)  =>
336                let val ts = map loop el                let val ts = map loop el
337                 in ltyChkenv (LT.ltc_tyc t);                 in ltyChkenv "VECTOR index " (LT.ltc_tyc t);
338                    map ltyChkenv ts;                    map (ltyChkenv "VECTOR vector ") ts;
339                    app (fn x => ltMatch le "VECTOR" (x, LT.ltc_tyc t)) ts;                    app (fn x => ltMatch le "VECTOR" (x, LT.ltc_tyc t)) ts;
340                    ltVector t                    ltVector t
341                end                end
# Line 325  Line 349 
349                       in check (kenv, venv', d) x                       in check (kenv, venv', d) x
350                      end                      end
351                    val ts = map h cl                    val ts = map h cl
352                    val _ = map ltyChkenv ts                    val _ = map (ltyChkenv "SWITCH branch ") ts
353                 in (case ts                 in (case ts
354                      of [] => bug "empty switch in checkLty"                      of [] => bug "empty switch in checkLty"
355                       | a::r =>                       | a::r =>
# Line 338  Line 362 
362            | ETAG(e, t) =>            | ETAG(e, t) =>
363                let val z = loop e   (* what do we check on e ? *)                let val z = loop e   (* what do we check on e ? *)
364                    val _ = ltMatch le "ETAG1" (z, LT.ltc_string)                    val _ = ltMatch le "ETAG1" (z, LT.ltc_string)
365                    val _ = ltyChkenv t                    val _ = ltyChkenv "ETAG " t
366                 in ltEtag t                 in ltEtag t
367                end                end
368    
# Line 361  Line 385 
385                let val ntc = if laterPhase(phase) then LT.tcc_void                let val ntc = if laterPhase(phase) then LT.tcc_void
386                              else (if b then LT.tcc_box t else LT.tcc_abs t)                              else (if b then LT.tcc_box t else LT.tcc_abs t)
387                    val nt = LT.ltc_tyc ntc                    val nt = LT.ltc_tyc ntc
388                    val _ = ltyChkenv nt                    val _ = ltyChkenv "UNWRAP " nt
389                 in (ltMatch le "UNWRAP" (loop e, nt); LT.ltc_tyc t)                 in (ltMatch le "UNWRAP" (loop e, nt); LT.ltc_tyc t)
390                end)                end)
391              end (* loop *)
392    in (* wrap loop with kind check of result *)    in (* wrap loop with kind check of result *)
393       fn x => let val y = loop x in ltyChkenv y; y end       fn x => let val y = loop x in ltyChkMsg "RESULT " x kenv y; y end
394   end (* end-of-fn-check *)   end (* end-of-fn-check *)
395    
396  in  in

Legend:
Removed from v.2044  
changed lines
  Added in v.2046

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