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 183, Sun Nov 8 16:58:19 1998 UTC revision 184, Sun Nov 8 21:18:20 1998 UTC
# Line 165  Line 165 
165             prList tcPrint "\n** argument Tycs:\n" ts;             prList tcPrint "\n** argument Tycs:\n" ts;
166             []))             []))
167    
168    fun ltArrow (le,s) (isfct,alts,rlts) =    fun ltArrow (le,s) (cconv,alts,rlts) =
169      (case isfct      (case cconv
170        of NONE => LT.ltc_fct (alts,rlts)        of CC_FCT => LT.ltc_fct (alts,rlts)
171         | SOME raw =>         | CC_FUN raw =>
172             (catchExn             (catchExn
173               (fn () => LT.ltc_arrow (raw,alts,rlts))               (fn () => LT.ltc_arrow (raw,alts,rlts))
174               (le,               (le,
# Line 264  Line 264 
264                             typeof e, mismatch (le,"LET"))) e')                             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 as {isrec=NONE,cconv,...},
268                         _, _, _)) :: fds', e) => let                         lv, _, _)) :: fds', e) => let
             val (fk, lv, _, _) = fd  
             val isfct = case fk of FK_FCT => NONE  
                                  | FK_FUN{fixed, ...} => SOME fixed  
269              val (alts,rlts) = typeofFn venv fd              val (alts,rlts) = typeofFn venv fd
270              val lt = ltArrow (le,"non-rec FIX") (isfct,alts,rlts)              val lt = ltArrow (le,"non-rec FIX") (cconv,alts,rlts)
271              val ve = extEnv (lv,lt,venv)              val ve = extEnv (lv,lt,venv)
272              val venv' =              val venv' =
273                if null fds' then ve                if null fds' then ve
# Line 282  Line 279 
279              end              end
280          | FIX (fds,e) => let          | FIX (fds,e) => let
281              val isfct = false              val isfct = false
282              fun extEnv ((FK_FCT, _, _, _), _) =              fun extEnv (({cconv=CC_FCT, ...}, _, _, _), _) =
283                    bug "unexpected case in extEnv"                    bug "unexpected case in extEnv"
284                | extEnv ((FK_FUN {isrec,fixed,...}, lv, vts, _) : fundec, ve) =                | extEnv (({isrec,cconv,...}, lv, vts, _) : fundec, ve) =
285                case (isrec, isfct)                case (isrec, isfct)
286                 of (SOME lts, false) => let                 of (SOME (lts,_), false) => let
287                      val lt = ltArrow (le,"FIX") (SOME fixed,                      val lt = ltArrow (le,"FIX") (cconv,
288                                                   map #2 vts, lts)                                                   map #2 vts, lts)
289                      in LT.ltInsert (ve,lv,lt,d)                      in LT.ltInsert (ve,lv,lt,d)
290                      end                      end
# Line 298  Line 295 
295                      in errMsg (le, "in FIX: " ^ msg ^ LV.lvarName lv, ve)                      in errMsg (le, "in FIX: " ^ msg ^ LV.lvarName lv, ve)
296                      end                      end
297              val venv' = foldl extEnv venv fds              val venv' = foldl extEnv venv fds
298              fun chkDcl ((FK_FUN {isrec = NONE, ...}, _, _, _) : fundec) = ()              fun chkDcl (({isrec = NONE, ...}, _, _, _) : fundec) = ()
299                | chkDcl (fd as (FK_FUN {isrec = SOME lts, ...}, _, _, _)) = let                | chkDcl (fd as ({isrec = SOME (lts,_), ...}, _, _, _)) = let
300                  in ltsMatch (le,"FIX") (lts, #2 (typeofFn venv' fd))                  in ltsMatch (le,"FIX") (lts, #2 (typeofFn venv' fd))
301                  end                  end
               | chkDcl _ = ()  
302              in              in
303                app chkDcl fds;                app chkDcl fds;
304                typeIn venv' e                typeIn venv' e
# Line 467  Line 463 
463      foldl (fn ((v,t), ve) => LT.ltInsert (ve,v,t,DI.top)) LT.initLtyEnv args      foldl (fn ((v,t), ve) => LT.ltInsert (ve,v,t,DI.top)) LT.initLtyEnv args
464    val err = check phase (LT.initTkEnv, ve, DI.top) lexp    val err = check phase (LT.initTkEnv, ve, DI.top) lexp
465    val err = case fkind    val err = case fkind
466       of FK_FCT => err       of {cconv=CC_FCT,...} => err
467        | _ => (say "**** Not a functor at top level\n"; true)        | _ => (say "**** Not a functor at top level\n"; true)
468    in err end    in err end
469    

Legend:
Removed from v.183  
changed lines
  Added in v.184

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