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/temi-branch/compiler/Elaborator/types/typecheck.sml
ViewVC logotype

Diff of /sml/branches/temi-branch/compiler/Elaborator/types/typecheck.sml

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

revision 3019, Tue May 6 20:25:44 2008 UTC revision 3020, Wed May 7 02:59:25 2008 UTC
# Line 115  Line 115 
115      end      end
116    
117    
118    fun findRegion ty =
119        case ty of
120            MARKty (t as MARKty(_, _), _) => findRegion t
121          | MARKty (_, pos) => SOME pos
122          | _ => NONE
123    
124  fun unifyErr{ty1,name1,ty2,name2,message=m,region,kind,kindname,phrase} =  fun unifyErr{ty1,name1,ty2,name2,message=m,region,kind,kindname,phrase} =
125      (unifyTy(ty1,ty2); true) handle Unify(mode) =>      (unifyTy(ty1,ty2); true) handle Unify(mode) =>
126        (err region COMPLAIN (message(m,mode))        (err region COMPLAIN (message(m,mode))
# Line 125  Line 131 
131                val spaces = "                                   "                val spaces = "                                   "
132                val pad1= substring(spaces,0,Int.max(0,len2-len1))                val pad1= substring(spaces,0,Int.max(0,len2-len1))
133                val pad2= substring(spaces,0,Int.max(0,len2-len1))                val pad2= substring(spaces,0,Int.max(0,len2-len1))
134                  val () = case (findRegion ty1, findRegion ty2) of
135                             (SOME t, _) => PP.string ppstrm "found mark"
136                           | (_, SOME t) => PP.string ppstrm "found mark"
137                           | _ => PP.string ppstrm "no mark"
138                val m = if m="" then name1 ^ " and " ^ name2 ^ " don't agree"                val m = if m="" then name1 ^ " and " ^ name2 ^ " don't agree"
139                        else m                        else m
140            in if name1="" then ()            in if name1="" then ()
# Line 270  Line 280 
280                | (VARty(ref(LITERAL _)) | VARty(ref(SCHEME _))) => ty                | (VARty(ref(LITERAL _)) | VARty(ref(SCHEME _))) => ty
281                | CONty(tyc,args) => CONty(tyc, map gen args) (*shareMap*)                | CONty(tyc,args) => CONty(tyc, map gen args) (*shareMap*)
282                | WILDCARDty => WILDCARDty                | WILDCARDty => WILDCARDty
283                  | MARKty(ty, region) =>
284                    let val () = ppTypeDebug (">> Markty", ty)
285                    in gen ty
286                    end
287                | _ => bug "generalizeTy -- bad arg"                | _ => bug "generalizeTy -- bad arg"
288    
289          val _ = ppTypeDebug (">>gen: before: ",!typ)          val _ = ppTypeDebug (">>gen: before: ",!typ)
# Line 336  Line 350 
350      case pat      case pat
351        of WILDpat => (pat,mkMETAtyBounded depth)        of WILDpat => (pat,mkMETAtyBounded depth)
352         | VARpat(VALvar{typ as ref UNDEFty,...}) =>         | VARpat(VALvar{typ as ref UNDEFty,...}) =>
353                (typ := mkMETAtyBounded depth; (pat,!typ))                (typ := mkMETAtyBounded depth; (pat,MARKty(!typ, region)))
354                                       (* multiple occurrence due to or-pat *)                                       (* multiple occurrence due to or-pat *)
355         | VARpat(VALvar{typ, ...}) => (pat, !typ)         | VARpat(VALvar{typ, ...}) => (pat, MARKty(!typ, region))
356         | INTpat (_,ty) => (oll_push ty; (pat,ty))         | INTpat (_,ty) => (oll_push ty; (pat,MARKty(ty, region)))
357         | WORDpat (_,ty) => (oll_push ty; (pat,ty))         | WORDpat (_,ty) => (oll_push ty; (pat,MARKty(ty, region)))
358         | REALpat _ => (pat,realTy)         | REALpat _ => (pat,MARKty(realTy, region))
359         | STRINGpat _ => (pat,stringTy)         | STRINGpat _ => (pat,MARKty(stringTy, region))
360         | CHARpat _ => (pat,charTy)         | CHARpat _ => (pat,MARKty(charTy, region))
361         | RECORDpat{fields,flex,typ} =>         | RECORDpat{fields,flex,typ} =>
362             (* fields assumed already sorted by label *)             (* fields assumed already sorted by label *)
363             let fun g(lab,pat') =             let fun g(lab,pat') =
# Line 358  Line 372 
372                       in registerFlex(tv,region);                       in registerFlex(tv,region);
373                          typ := ty; (npat,ty)                          typ := ty; (npat,ty)
374                      end                      end
375                 else (npat,recordTy(labtys))                 else (npat,MARKty(recordTy(labtys), region))
376             end             end
377         | VECTORpat(pats,_) =>         | VECTORpat(pats,_) =>
378            (let val (npats,ntys) =            (let val (npats,ntys) =
379                       mapUnZip (fn pat => patType(pat,depth,region)) pats                       mapUnZip (fn pat => patType(pat,depth,region)) pats
380                 val nty =                 val nty =
381                 foldr (fn (a,b) => (unifyTy(a,b); b)) (mkMETAtyBounded depth) ntys                 foldr (fn (a,b) => (unifyTy(a,b); b)) (mkMETAtyBounded depth) ntys
382              in (VECTORpat(npats,nty), CONty(vectorTycon,[nty]))              in (VECTORpat(npats,nty),
383                    MARKty(CONty(vectorTycon,[nty]), region))
384             end handle Unify(mode) => (             end handle Unify(mode) => (
385               err region COMPLAIN               err region COMPLAIN
386                   (message("vector pattern type failure",mode)) nullErrorBody;                   (message("vector pattern type failure",mode)) nullErrorBody;
# Line 377  Line 392 
392               unifyErr{ty1=ty1,ty2=ty2,name1="expected",name2="found",               unifyErr{ty1=ty1,ty2=ty2,name1="expected",name2="found",
393                        message="or-patterns don't agree",region=region,                        message="or-patterns don't agree",region=region,
394                        kind=ppPat,kindname="pattern",phrase=pat};                        kind=ppPat,kindname="pattern",phrase=pat};
395               (ORpat(p1, p2), ty1)               (ORpat(p1, p2), MARKty(ty1, region))
396             end             end
397         | CONpat(dcon as DATACON{typ,...},_) =>         | CONpat(dcon as DATACON{typ,...},_) =>
398             let val (ty, insts) = instantiatePoly typ             let val (ty, insts) = instantiatePoly typ
# Line 387  Line 402 
402                 val nty = mkMETAtyBounded depth                 val nty = mkMETAtyBounded depth
403                 val _ = unifyTy(nty, ty)                 val _ = unifyTy(nty, ty)
404              in (** (CONpat(dcon,insts),ty) *)              in (** (CONpat(dcon,insts),ty) *)
405                 (CONpat(dcon, insts), ty)                 (CONpat(dcon, insts), MARKty(ty, region))
406             end             end
407         | APPpat(dcon as DATACON{typ,rep,...},_,arg) =>         | APPpat(dcon as DATACON{typ,rep,...},_,arg) =>
408             let val (argpat,argty) = patType(arg,depth,region)             let val (argpat,argty) = patType(arg,depth,region)
# Line 396  Line 411 
411                                     | _ => (typ,dcon)                                     | _ => (typ,dcon)
412                 val (ty2,insts) = instantiatePoly ty1                 val (ty2,insts) = instantiatePoly ty1
413                 val npat = APPpat(ndcon,insts,argpat)                 val npat = APPpat(ndcon,insts,argpat)
414              in (npat,applyType(ty2,argty))              in (npat,MARKty(applyType(ty2,argty), region))
415                 handle Unify(mode) =>                 handle Unify(mode) =>
416                  (err region COMPLAIN                  (err region COMPLAIN
417                    (message("constructor and argument don't agree in pattern",mode))                    (message("constructor and argument don't agree in pattern",mode))
# Line 416  Line 431 
431              in if unifyErr{ty1=patTy,name1="pattern",ty2=ty,name2="constraint",              in if unifyErr{ty1=patTy,name1="pattern",ty2=ty,name2="constraint",
432                          message="pattern and constraint don't agree",                          message="pattern and constraint don't agree",
433                          region=region,kind=ppPat,kindname="pattern",phrase=pat}                          region=region,kind=ppPat,kindname="pattern",phrase=pat}
434                  then (CONSTRAINTpat(npat,ty),ty)                  then (CONSTRAINTpat(npat,MARKty(ty, region)),
435                                            (MARKty(ty, region)))
436                  else (pat,WILDCARDty)                  else (pat,WILDCARDty)
437             end             end
438         | LAYEREDpat(vpat as VARpat(VALvar{typ,...}),pat') =>         | LAYEREDpat(vpat as VARpat(VALvar{typ,...}),pat') =>
439             let val (npat,patTy) = patType(pat',depth,region)             let val (npat,patTy) = patType(pat',depth,region)
440                 val _ = (typ := patTy)                 val _ = (typ := patTy)
441              in (LAYEREDpat(vpat,npat),patTy)              in (LAYEREDpat(vpat,npat),MARKty(patTy, region))
442             end             end
443         | LAYEREDpat(cpat as CONSTRAINTpat(VARpat(VALvar{typ,...}),ty),pat') =>         | LAYEREDpat(cpat as CONSTRAINTpat(VARpat(VALvar{typ,...}),ty),pat') =>
444             let val (npat,patTy) = patType(pat',depth,region)             let val (npat,patTy) = patType(pat',depth,region)
445              in if unifyErr{ty1=patTy,name1="pattern",ty2=ty,name2="constraint",              in if unifyErr{ty1=patTy,name1="pattern",ty2=ty,name2="constraint",
446                             message="pattern and constraint don't agree",                             message="pattern and constraint don't agree",
447                             region=region,kind=ppPat,kindname="pattern",phrase=pat}                             region=region,kind=ppPat,kindname="pattern",phrase=pat}
448                     then (typ := ty; (LAYEREDpat(cpat,npat),ty))                     then (typ := ty; (LAYEREDpat(cpat,npat),MARKty(ty, region)))
449                    else (pat,WILDCARDty)                    else (pat,WILDCARDty)
450             end             end
451         | p => bug "patType -- unexpected pattern"         | p => bug "patType -- unexpected pattern"
# Line 446  Line 462 
462          in          in
463              if boolUnifyErr { ty = t1, name = "operand", message = m }              if boolUnifyErr { ty = t1, name = "operand", message = m }
464              andalso boolUnifyErr { ty = t2, name = "operand", message = m }              andalso boolUnifyErr { ty = t2, name = "operand", message = m }
465              then (con (e1', e2'), boolTy)              then (con (e1', e2'), MARKty(boolTy, region))
466              else (exp, WILDCARDty)              else (exp, WILDCARDty)
467          end          end
468  in  in
469       case exp       case exp
470        of VARexp(r as ref(VALvar{typ, ...}), _) =>        of VARexp(r as ref(VALvar{typ, ...}), _) =>
471             let val (ty, insts) = instantiatePoly(!typ)             let val (ty, insts) = instantiatePoly(!typ)
472              in (VARexp(r, insts), ty)              in (VARexp(r, insts), MARKty(ty, region))
473             end             end
474         | VARexp(refvar as ref(OVLDvar _),_) =>         | VARexp(refvar as ref(OVLDvar _),_) =>
475             (exp, ol_push (refvar, err region))             (exp, ol_push (refvar, err region))
476         | VARexp(r as ref ERRORvar, _) => (exp, WILDCARDty)         | VARexp(r as ref ERRORvar, _) => (exp, WILDCARDty)
477         | CONexp(dcon as DATACON{typ,...},_) =>         | CONexp(dcon as DATACON{typ,...},_) =>
478             let val (ty,insts) = instantiatePoly typ             let val (ty,insts) = instantiatePoly typ
479              in (CONexp(dcon, insts), ty)              in (CONexp(dcon, insts), MARKty(ty, region))
480             end             end
481         | INTexp (_,ty) => (oll_push ty; (exp,ty))         | INTexp (_,ty) => (oll_push ty; (exp, MARKty(ty, region)))
482         | WORDexp (_,ty) => (oll_push ty; (exp,ty))         | WORDexp (_,ty) => (oll_push ty; (exp,MARKty(ty, region)))
483         | REALexp _ => (exp,realTy)         | REALexp _ => (exp,MARKty(realTy, region))
484         | STRINGexp _ => (exp,stringTy)         | STRINGexp _ => (exp,MARKty(stringTy, region))
485         | CHARexp _ => (exp,charTy)         | CHARexp _ => (exp,MARKty(charTy, region))
486         | RECORDexp fields =>         | RECORDexp fields =>
487             let fun h(l as LABEL{name,...},exp') =             let fun h(l as LABEL{name,...},exp') =
488                      let val (nexp,nty) = expType(exp',occ,tdepth,region)                      let val (nexp,nty) = expType(exp',occ,tdepth,region)
# Line 475  Line 491 
491                 fun extract(LABEL{name,...},t) = (name,t)                 fun extract(LABEL{name,...},t) = (name,t)
492                 val (fields',tfields) = mapUnZip h fields                 val (fields',tfields) = mapUnZip h fields
493                 val rty = map extract (sortFields tfields)                 val rty = map extract (sortFields tfields)
494              in (RECORDexp fields',recordTy(rty))              in (RECORDexp fields',MARKty(recordTy(rty), region))
495             end             end
496         | SELECTexp (l, e) =>         | SELECTexp (l, e) =>
497             let val (nexp, nty) = expType(e, occ, tdepth, region)             let val (nexp, nty) = expType(e, occ, tdepth, region)
# Line 484  Line 500 
500                 val tv = mkTyvar(mkFLEX(labtys,infinity))                 val tv = mkTyvar(mkFLEX(labtys,infinity))
501                 val pt = VARty tv                 val pt = VARty tv
502                 val _ = registerFlex(tv,region)                 val _ = registerFlex(tv,region)
503              in (unifyTy(pt,nty); (SELECTexp(l, nexp), res))              in (unifyTy(pt,nty); (SELECTexp(l, nexp), MARKty(res, region)))
504                 handle Unify(mode) =>                 handle Unify(mode) =>
505                   (err region COMPLAIN                   (err region COMPLAIN
506                    (message("selecting a non-existing field from a record",mode))                    (message("selecting a non-existing field from a record",mode))
# Line 504  Line 520 
520         | VECTORexp(exps,_) =>         | VECTORexp(exps,_) =>
521            (let val (exps',nty) = mapUnZip (fn e => expType(e,occ,tdepth,region)) exps            (let val (exps',nty) = mapUnZip (fn e => expType(e,occ,tdepth,region)) exps
522                 val vty = foldr (fn (a,b) => (unifyTy(a,b); b)) (mkMETAty()) nty                 val vty = foldr (fn (a,b) => (unifyTy(a,b); b)) (mkMETAty()) nty
523              in (VECTORexp(exps',vty), CONty(vectorTycon,[vty]))              in (VECTORexp(exps',vty),
524                    MARKty(CONty(vectorTycon,[vty]), region))
525             end handle Unify(mode) =>             end handle Unify(mode) =>
526             (err region COMPLAIN             (err region COMPLAIN
527               (message("vector expression type failure",mode))               (message("vector expression type failure",mode))
# Line 521  Line 538 
538                        in (e'::el',ety)                        in (e'::el',ety)
539                       end                       end
540                 val (exps',expty) = scan exps                 val (exps',expty) = scan exps
541              in (SEQexp exps',expty)              in (SEQexp exps',MARKty(expty, region))
542             end             end
543         | APPexp(rator, rand) =>         | APPexp(rator, rand) =>
544             let val (rator',ratorTy) = expType(rator,occ,tdepth,region)             let val (rator',ratorTy) = expType(rator,occ,tdepth,region)
545                 val (rand',randTy) = expType(rand,occ,tdepth,region)                 val (rand',randTy) = expType(rand,occ,tdepth,region)
546                 val exp' = APPexp(rator',rand')                 val exp' = APPexp(rator',rand')
547              in (exp',applyType(ratorTy,randTy))              in (exp',applyType(ratorTy,MARKty(randTy, region)))
548                 handle Unify(mode) =>                 handle Unify(mode) =>
549                 let val ratorTy = prune ratorTy                 let val ratorTy = prune ratorTy
550                     val reducedRatorTy = headReduceType ratorTy                     val reducedRatorTy = headReduceType ratorTy
# Line 564  Line 581 
581                          message="expression doesn't match constraint",                          message="expression doesn't match constraint",
582                          region=region,kind=ppExp,kindname="expression",                          region=region,kind=ppExp,kindname="expression",
583                          phrase=exp}                          phrase=exp}
584                  then (CONSTRAINTexp(e',ty),ty)                  then (CONSTRAINTexp(e',MARKty(ty, region)),
585                            MARKty(ty, region))
586                  else (exp,WILDCARDty)                  else (exp,WILDCARDty)
587             end             end
588         | HANDLEexp(e, (rules, _)) =>         | HANDLEexp(e, (rules, _)) =>
589             let val (e',ety) = expType(e,occ,tdepth,region)             let val (e',ety) = expType(e,occ,tdepth,region)
590                 and (rules',rty,hty) = matchType (rules, occ, region)                 and (rules',rty,hty) = matchType (rules, occ, region)
591                 val exp' = HANDLEexp(e', (rules', rty))                 val exp' = HANDLEexp(e', (rules', rty))
592              in (unifyTy(hty, exnTy --> ety); (exp',ety))              in (unifyTy(hty, exnTy --> ety); (exp',MARKty(ety, region)))
593                 handle Unify(mode) =>                 handle Unify(mode) =>
594                   (if unifyErr{ty1=domain(prune hty), name1="handler domain",                   (if unifyErr{ty1=domain(prune hty), name1="handler domain",
595                               ty2=exnTy, name2="",                               ty2=exnTy, name2="",
# Line 592  Line 610 
610              in unifyErr{ty1=ety, name1="raised", ty2=exnTy, name2="",              in unifyErr{ty1=ety, name1="raised", ty2=exnTy, name2="",
611                          message="argument of raise is not an exception",                          message="argument of raise is not an exception",
612                          region=region,kind=ppExp,kindname="expression",phrase=exp};                          region=region,kind=ppExp,kindname="expression",phrase=exp};
613                 (RAISEexp(e',newty),newty)                 (RAISEexp(e',newty),MARKty(newty, region))
614             end             end
615         | LETexp(d,e) =>         | LETexp(d,e) =>
616             let val d' = decType0(d,LetDef(occ),tdepth,region)             let val d' = decType0(d,LetDef(occ),tdepth,region)
617                 val (e',ety) = expType(e,occ,tdepth,region)                 val (e',ety) = expType(e,occ,tdepth,region)
618              in (LETexp(d',e'),ety)              in (LETexp(d',e'),MARKty(ety, region))
619             end             end
620         | CASEexp(e,rules,isMatch) =>         | CASEexp(e,rules,isMatch) =>
621             let val (e',ety) = expType(e,occ,tdepth,region)             let val (e',ety) = expType(e,occ,tdepth,region)
622                 val (rules',_,rty) = matchType(rules,occ,region)                 val (rules',_,rty) = matchType(rules,occ,region)
623                 val exp' = CASEexp(e',rules', isMatch)                 val exp' = CASEexp(e',rules', isMatch)
624              in (exp',applyType(rty,ety))              in (exp',MARKty(applyType(rty,ety), region))
625                 handle Unify(mode) =>                 handle Unify(mode) =>
626                 (if isMatch then                 (if isMatch then
627                      unifyErr{ty1=domain rty, name1="rule domain",                      unifyErr{ty1=domain rty, name1="rule domain",
# Line 642  Line 660 
660                 then                 then
661                     (IFexp { test = test', thenCase = thenCase',                     (IFexp { test = test', thenCase = thenCase',
662                              elseCase = elseCase' },                              elseCase = elseCase' },
663                      tct)                      MARKty(tct, region))
664                 else                 else
665                     (exp, WILDCARDty)                     (exp, WILDCARDty)
666             end             end
# Line 657  Line 675 
675                 if boolUnifyErr { ty = tty, name = "test expression",                 if boolUnifyErr { ty = tty, name = "test expression",
676                                   message = "test expression in while is not of type bool" }                                   message = "test expression in while is not of type bool" }
677                 then                 then
678                     (WHILEexp { test = test', expr = expr' }, unitTy)                     (WHILEexp { test = test', expr = expr' }, MARKty(unitTy, region))
679                 else                 else
680                     (exp, WILDCARDty)                     (exp, WILDCARDty)
681             end             end
682         | FNexp(rules,_) =>         | FNexp(rules,_) =>
683             let val (rules',ty,rty) = matchType(rules,occ,region)             let val (rules',ty,rty) = matchType(rules,occ,region)
684              in (FNexp(rules',ty),rty)              in (FNexp(rules',ty),MARKty(rty, region))
685             end             end
686         | MARKexp(e,region) =>         | MARKexp(e,region) =>
687             let val (e',et) = expType(e,occ,tdepth,region)             let val (e',et) = expType(e,occ,tdepth,region)
688              in (MARKexp(e',region),et)              in (MARKexp(e',region),MARKty(et, region))
689             end             end
690         | _ => bug "exptype -- bad expression"         | _ => bug "exptype -- bad expression"
691  end  end

Legend:
Removed from v.3019  
changed lines
  Added in v.3020

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