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/SMLNJ/src/compiler/FLINT/flint/chkflint.sml
ViewVC logotype

Diff of /sml/branches/SMLNJ/src/compiler/FLINT/flint/chkflint.sml

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

revision 68, Fri Apr 3 00:06:42 1998 UTC revision 69, Fri Apr 3 00:06:55 1998 UTC
# Line 6  Line 6 
6  signature CHKFLINT = sig  signature CHKFLINT = sig
7    
8  (** which set of the typing rules to use while doing the typecheck *)  (** which set of the typing rules to use while doing the typecheck *)
9  type typsys (* currently very crude, i.e., = int or phases *)  type typsys (* currently very crude *)
10    
11  val checkTop : FLINT.fundec * typsys -> bool  val checkTop : FLINT.fundec * typsys -> bool
12  val checkExp : FLINT.lexp * typsys -> bool  val checkExp : FLINT.lexp * typsys -> bool
# Line 17  Line 17 
17  struct  struct
18    
19  (** which set of the typing rules to use while doing the typecheck *)  (** which set of the typing rules to use while doing the typecheck *)
20  type typsys = int (* currently very crude, use int for phases *)  type typsys = bool (* currently very crude *)
21    
22  local structure LT = LtyExtern  local structure LT = LtyExtern
23        structure LV = LambdaVar        structure LV = LambdaVar
24        structure DA = Access        structure DA = Access
25        structure DI = DebIndex        structure DI = DebIndex
26        structure PP = PPFlint        structure PP = PPFlint
27          structure PO = PrimOp
28        open FLINT        open FLINT
29    
30  fun bug s = ErrorMsg.impossible ("ChkFlint: "^s)  fun bug s = ErrorMsg.impossible ("ChkFlint: "^s)
# Line 83  Line 84 
84      (le, fn () => g () before say ("\n** exception " ^ exnName ex ^ " raised"))      (le, fn () => g () before say ("\n** exception " ^ exnName ex ^ " raised"))
85    
86  (*** a hack for type checkng ***)  (*** a hack for type checkng ***)
87  fun laterPhase i = i > 20  fun laterPhase postReify = postReify
88    
89  fun check phase envs lexp = let  fun check phase envs lexp = let
90    val ltEquiv = LT.lt_eqv_x (* should be LT.lt_eqv *)    val ltEquiv = LT.lt_eqv_x (* should be LT.lt_eqv *)
91    fun ltTAppChk (lt, ts, kenv) = LT.lt_inst(lt, ts)    val ltTAppChk =
92        if !Control.CG.checkKinds then LT.lt_inst_chk_gen()
93        else fn (lt,ts,_) => LT.lt_inst(lt,ts)
94    
95    fun constVoid _ = LT.ltc_void    fun constVoid _ = LT.ltc_void
96    val (ltString,ltExn,ltEtag,ltVector,ltWrap) =    val (ltString,ltExn,ltEtag,ltVector,ltWrap,ltBool) =
97      if laterPhase phase then      if laterPhase phase then
98        (LT.ltc_void, LT.ltc_void, constVoid, constVoid, constVoid)        (LT.ltc_string, LT.ltc_void, constVoid, constVoid, constVoid,
99           LT.ltc_void)
100      else      else
101        (LT.ltc_string, LT.ltc_exn, LT.ltc_etag, LT.ltc_tyc o LT.tcc_vector,        (LT.ltc_string, LT.ltc_exn, LT.ltc_etag, LT.ltc_tyc o LT.tcc_vector,
102         LT.ltc_tyc o LT.tcc_box)         LT.ltc_tyc o LT.tcc_box, LT.ltc_bool)
103    
104    fun prMsgLt (s,lt) = (say s; ltPrint lt)    fun prMsgLt (s,lt) = (say s; ltPrint lt)
105    
# Line 129  Line 133 
133    local    local
134      fun ltFnAppGen opr (le,s,msg) (t,ts) =      fun ltFnAppGen opr (le,s,msg) (t,ts) =
135        catchExn        catchExn
136          (fn () => let val (xs,ys) = opr (LT.lt_arrowN t)          (fn () => let val (xs,ys) = opr (LT.ltd_fkfun t)
                   (*** lt_arrowN may go away soon, and functors and functions  
                        have to be treated differently anyway, using different  
                        algorithms for comparing datatypes (probably)  
                    ***)  
137              in ltsMatch (le,s) (xs,ts); ys              in ltsMatch (le,s) (xs,ts); ys
138              end)              end)
139          (le, fn () => (prMsgLt (s ^ msg ^ "\n** type:\n", t); []))          (le, fn () => (prMsgLt (s ^ msg ^ "\n** type:\n", t); []))
# Line 358  Line 358 
358                              (le,                              (le,
359                               "BRANCK : primop must return single result ",                               "BRANCK : primop must return single result ",
360                               LT.ltc_void)                               LT.ltc_void)
361                  val _ = ltMatch fp (lt, LT.ltc_bool)                  val _ = ltMatch fp (lt, ltBool)
362                  val lts1 = typeof e1                  val lts1 = typeof e1
363                  val lts2 = typeof e2                  val lts2 = typeof e2
364               in ltsMatch fp (lts1, lts2);               in ltsMatch fp (lts1, lts2);
365                  lts1                  lts1
366              end              end
367            | PRIMOP ((_,PO.WCAST,lt,[]), [u], lv, e) =>
368                (*** a hack: checked only after reifY is done ***)
369                if laterPhase phase then
370                  (case LT.ltd_fct lt
371                    of ([argt], [rt]) =>
372                          (ltMatch (le, "WCAST") (typeofVal u, argt);
373                           typeWith (lv, rt) e)
374                     | _ => bug "unexpected WCAST in typecheck")
375                else bug "unexpected WCAST in typecheck"
376          | PRIMOP ((_,_,lt,ts), vs, lv, e) =>          | PRIMOP ((_,_,lt,ts), vs, lv, e) =>
377            typeWithBindingToSingleRsltOfInstAndApp ("PRIMOP",lt,ts,vs,lv) e            typeWithBindingToSingleRsltOfInstAndApp ("PRIMOP",lt,ts,vs,lv) e
378  (*  (*

Legend:
Removed from v.68  
changed lines
  Added in v.69

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