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/kernel/lty.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/kernel/lty.sml

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

revision 2031, Fri Aug 18 20:55:00 2006 UTC revision 2032, Fri Aug 18 21:19:55 2006 UTC
# Line 785  Line 785 
785          (* default recursive invocation *)          (* default recursive invocation *)
786          val g = tkTyc kenv          val g = tkTyc kenv
787          (* how to compute the kind of a tyc *)          (* how to compute the kind of a tyc *)
788          fun mk() =          fun mkI tycI =
789              case tc_outX t of              case tycI of
790                  TC_VAR (i, j) =>                  TC_VAR (i, j) =>
791                  tkLookup (kenv, i, j)                  tkLookup (kenv, i, j)
792                | TC_NVAR _ =>                | TC_NVAR _ =>
# Line 863  Line 863 
863                     in chkKindEnv(env,j,kenv);                     in chkKindEnv(env,j,kenv);
864                        tkTyc bodyKenv body                        tkTyc bodyKenv body
865                     end)                     end)
866                | TC_IND _ => bug "unexpected TC_IND in tkTyc"              (*  | TC_IND _ =>  bug "unexpected TC_IND in tkTyc" *)
867                  | TC_IND(newtyc, oldtycI) =>
868                      let val newtycknd = g newtyc
869                      in
870                          if tk_eq(newtycknd, mkI oldtycI)
871                          then newtycknd
872                          else bug "tkTyc[IND]: new tyc and old tycI kind mismatch"
873                      end
874                | TC_CONT _ => bug "unexpected TC_CONT in tkTyc"                | TC_CONT _ => bug "unexpected TC_CONT in tkTyc"
875            fun mk () =
876                mkI (tc_outX t)
877      in      in
878          Memo.recallOrCompute (dict, kenv, t, mk)          Memo.recallOrCompute (dict, kenv, t, mk)
879      end      end
# Line 903  Line 912 
912    
913  fun ltyChk (lty : lty) =  fun ltyChk (lty : lty) =
914      let val (tkChk, chkKindEnv) = tkTycGen'()      let val (tkChk, chkKindEnv) = tkTycGen'()
915          fun ltyChk' (kenv : tkindEnv) (lty : lty) =          fun ltyIChk (kenv : tkindEnv) (ltyI : ltyI) =
916              (case lt_outX lty              (case ltyI
917                of LT_TYC(tyc) =>                of LT_TYC(tyc) =>
918                     (tkAssertIsMono (tkChk kenv tyc); tkc_mono)                     (tkAssertIsMono (tkChk kenv tyc); tkc_mono)
919                 | LT_STR(ltys) => tkc_seq(map (ltyChk' kenv) ltys)                 | LT_STR(ltys) => tkc_seq(map (ltyChk' kenv) ltys)
# Line 915  Line 924 
924                         tkc_fun(paramks,                         tkc_fun(paramks,
925                                tkc_seq(map (ltyChk' tenv') rngLtys))                                tkc_seq(map (ltyChk' tenv') rngLtys))
926                     end                     end
                     (* TODO might need a little more here *)  
927                 | LT_POLY(ks, ltys) =>                 | LT_POLY(ks, ltys) =>
928                     tkc_seq(map (ltyChk' (ks::kenv)) ltys)                     tkc_seq(map (ltyChk' (ks::kenv)) ltys)
929                     (* ??? *)                     (* ??? *)
930                 | LT_CONT(ltys) =>                 | LT_CONT(ltys) =>
931                     tkc_seq(map (ltyChk' kenv) ltys)                     tkc_seq(map (ltyChk' kenv) ltys)
932                 | LT_IND(thunk, sigltyI) =>                 | LT_IND(newLty, oldLtyI) =>
933                     (ltyChk' kenv) thunk                     let val newLtyKnd = (ltyChk' kenv) newLty
934                     (* TODO Need to check against sigltyI kind also? *)                     in if tk_eq(newLtyKnd, ltyIChk kenv oldLtyI)
935                          then newLtyKnd
936                          else bug "ltyChk[IND]: kind mismatch"
937                       end
938                 | LT_ENV(body, i, j, env) =>                 | LT_ENV(body, i, j, env) =>
939                     (* Should be the same as checking TC_ENV *)                     (* Should be the same as checking TC_ENV and
940                        * therefore the two cases should probably just
941                        * call the same helper function *)
942                     (let val kenv' =                     (let val kenv' =
943                              List.drop(kenv, j)                              List.drop(kenv, j)
944                              handle Subscript =>                              handle Subscript =>
# Line 939  Line 952 
952                      in chkKindEnv(env,j,kenv);                      in chkKindEnv(env,j,kenv);
953                         ltyChk' bodyKenv body                         ltyChk' bodyKenv body
954                      end))                      end))
955            and ltyChk' kenv lty = ltyIChk kenv (lt_outX lty)
956      in ltyChk' [] lty      in ltyChk' [] lty
957      end (* function ltyChk *)      end (* function ltyChk *)
958  end (* local *)  end (* local *)

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

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