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

Diff of /sml/trunk/src/compiler/FLINT/flint/chkflint.sml

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

revision 74, Sat Apr 11 00:22:45 1998 UTC revision 75, Sun Apr 12 02:22:44 1998 UTC
# Line 87  Line 87 
87  fun laterPhase postReify = postReify  fun laterPhase postReify = postReify
88    
89  fun check phase envs lexp = let  fun check phase envs lexp = let
90        (* imperative table -- keeps track of already bound variables,
91         * so we can tell if a variable is re-bound (which should be
92         * illegal).  Note that lvars and tvars actually share the same
93         * namespace!   --league, 11 April 1998
94         *)
95      val definedLvars = Intset.new()
96      fun lvarDef le (lvar:lvar) =
97          if Intset.mem definedLvars lvar then
98              errMsg (le, ("lvar " ^ (LambdaVar.prLvar lvar) ^ " redefined"), ())
99          else
100              Intset.add definedLvars lvar
101    
102    val ltEquiv = LT.lt_eqv_x (* should be LT.lt_eqv *)    val ltEquiv = LT.lt_eqv_x (* should be LT.lt_eqv *)
103    val ltTAppChk =    val ltTAppChk =
104      if !Control.CG.checkKinds then LT.lt_inst_chk_gen()      if !Control.CG.checkKinds then LT.lt_inst_chk_gen()
# Line 189  Line 201 
201          | (INT32 _ | WORD32 _) => LT.ltc_int32          | (INT32 _ | WORD32 _) => LT.ltc_int32
202          | REAL _ => LT.ltc_real          | REAL _ => LT.ltc_real
203          | STRING _ => LT.ltc_string          | STRING _ => LT.ltc_string
204        fun typeofFn ve (_,_,vts,eb) = let        fun typeofFn ve (_,lvar,vts,eb) = let
205          fun split ((lv,t), (ve,ts)) = (LT.ltInsert (ve,lv,t,d), t::ts)          fun split ((lv,t), (ve,ts)) =
206                (lvarDef le lv;
207                 (LT.ltInsert (ve,lv,t,d), t::ts))
208          val (ve',ts) = foldr split (ve,[]) vts          val (ve',ts) = foldr split (ve,[]) vts
209          in (ts, typeIn ve' eb)          in
210                lvarDef le lvar;
211                (ts, typeIn ve' eb)
212          end          end
213    
214        (* There are lvars hidden in Access.conrep, used by dcon.        (* There are lvars hidden in Access.conrep, used by dcon.
# Line 243  Line 259 
259        in case le        in case le
260         of RET vs => map typeofVal vs         of RET vs => map typeofVal vs
261          | LET (lvs,e,e') =>          | LET (lvs,e,e') =>
262            typeIn (foldl2 (extEnv, venv, lvs, typeof e, mismatch (le,"LET"))) e'            (app (lvarDef le) lvs;
263               typeIn (foldl2 (extEnv, venv, lvs,
264                               typeof e, mismatch (le,"LET"))) e')
265          | FIX ([],e) =>          | FIX ([],e) =>
266            (say "\n**** Warning: empty declaration list in FIX\n"; typeof e)            (say "\n**** Warning: empty declaration list in FIX\n"; typeof e)
267          | FIX ((fd as ((FK_FUN{isrec=NONE,...} | FK_FCT),          | FIX ((fd as ((FK_FUN{isrec=NONE,...} | FK_FCT),
# Line 291  Line 309 
309              end              end
310          | APP (v,vs) => ltFnApp (le,"APP") (typeofVal v, map typeofVal vs)          | APP (v,vs) => ltFnApp (le,"APP") (typeofVal v, map typeofVal vs)
311          | TFN ((lv,tks,e), e') => let          | TFN ((lv,tks,e), e') => let
312              val ks = map #2 tks              fun getkind (tv,tk) = (lvarDef le tv; tk)
313                val ks = map getkind tks
314              val lts = typeInEnv (LT.tkInsert (kenv,ks), venv, DI.next d) e              val lts = typeInEnv (LT.tkInsert (kenv,ks), venv, DI.next d) e
315              in typeWith (lv, LT.ltc_poly (ks,lts)) e'              in
316                    lvarDef le lv;
317                    typeWith (lv, LT.ltc_poly (ks,lts)) e'
318              end              end
319          | TAPP (v,ts) => ltTyApp (le,"TAPP") (typeofVal v, ts, kenv)          | TAPP (v,ts) => ltTyApp (le,"TAPP") (typeofVal v, ts, kenv)
320          | SWITCH (_,_,[],_) => errMsg (le,"empty SWITCH",[])          | SWITCH (_,_,[],_) => errMsg (le,"empty SWITCH",[])
# Line 307  Line 328 
328                        val fp = (le,"SWITCH DECON")                        val fp = (le,"SWITCH DECON")
329                        val ct = chkSnglInst fp (lt,ts)                        val ct = chkSnglInst fp (lt,ts)
330                        val nts = ltFnAppR fp (ct, [selLty])                        val nts = ltFnAppR fp (ct, [selLty])
331                        in foldl2 (extEnv, venv, [v], nts, mismatch fp)                        in
332                              lvarDef le v;
333                              foldl2 (extEnv, venv, [v], nts, mismatch fp)
334                        end                        end
335                    | (INTcon _ | WORDcon _) => g LT.ltc_int                    | (INTcon _ | WORDcon _) => g LT.ltc_int
336                    | (INT32con _ | WORD32con _) => g LT.ltc_int32                    | (INT32con _ | WORD32con _) => g LT.ltc_int32
# Line 329  Line 352 
352              end              end
353          | CON ((_,conrep,lt), ts, u, lv, e) =>          | CON ((_,conrep,lt), ts, u, lv, e) =>
354              (checkConrep conrep;              (checkConrep conrep;
355                 lvarDef le lv;
356               typeWithBindingToSingleRsltOfInstAndApp ("CON",lt,ts,[u],lv) e)               typeWithBindingToSingleRsltOfInstAndApp ("CON",lt,ts,[u],lv) e)
357          | RECORD (rk,vs,lv,e) => let          | RECORD (rk,vs,lv,e) => let
358              val lt = case rk              val lt = case rk
# Line 354  Line 378 
378                      in LT.ltc_tuple (map chkMono vs)                      in LT.ltc_tuple (map chkMono vs)
379                      end                      end
380                  | RK_STRUCT => LT.ltc_str (map typeofVal vs)                  | RK_STRUCT => LT.ltc_str (map typeofVal vs)
381              in typeWith (lv,lt) e              in
382                    lvarDef le lv;
383                    typeWith (lv,lt) e
384              end              end
385          | SELECT (v,n,lv,e) => let          | SELECT (v,n,lv,e) => let
386              val lt = catchExn              val lt = catchExn
# Line 362  Line 388 
388                  (le,                  (le,
389                   fn () =>                   fn () =>
390                      (say "SELECT from wrong type or out of range"; LT.ltc_void))                      (say "SELECT from wrong type or out of range"; LT.ltc_void))
391              in typeWith (lv,lt) e              in
392                    lvarDef le lv;
393                    typeWith (lv,lt) e
394              end              end
395          | RAISE (v,lts) => (ltMatch (le,"RAISE") (typeofVal v, ltExn); lts)          | RAISE (v,lts) => (ltMatch (le,"RAISE") (typeofVal v, ltExn); lts)
396          | HANDLE (e,v) => let val lts = typeof e          | HANDLE (e,v) => let val lts = typeof e
# Line 386  Line 414 
414          | PRIMOP ((_,PO.WCAST,lt,[]), [u], lv, e) =>          | PRIMOP ((_,PO.WCAST,lt,[]), [u], lv, e) =>
415              (*** a hack: checked only after reifY is done ***)              (*** a hack: checked only after reifY is done ***)
416              if laterPhase phase then              if laterPhase phase then
417                (case LT.ltd_fct lt                (lvarDef le lv;
418                   case LT.ltd_fct lt
419                  of ([argt], [rt]) =>                  of ([argt], [rt]) =>
420                        (ltMatch (le, "WCAST") (typeofVal u, argt);                        (ltMatch (le, "WCAST") (typeofVal u, argt);
421                         typeWith (lv, rt) e)                         typeWith (lv, rt) e)
# Line 405  Line 434 
434                  | checkDict (NONE : dict option) = ()                  | checkDict (NONE : dict option) = ()
435            in            in
436                checkDict dc;                checkDict dc;
437                  lvarDef le lv;
438                typeWithBindingToSingleRsltOfInstAndApp ("PRIMOP",lt,ts,vs,lv) e                typeWithBindingToSingleRsltOfInstAndApp ("PRIMOP",lt,ts,vs,lv) e
439            end            end
440  (*  (*

Legend:
Removed from v.74  
changed lines
  Added in v.75

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