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-3/compiler/Elaborator/types/unify.sml
[smlnj] / sml / branches / primop-branch-3 / compiler / Elaborator / types / unify.sml  
ViewVC logotype

Diff of /sml/branches/primop-branch-3/compiler/Elaborator/types/unify.sml

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

revision 2530, Thu May 10 00:04:43 2007 UTC revision 2531, Thu May 10 01:30:53 2007 UTC
# Line 10  Line 10 
10      | TYC of Types.tycon * Types.tycon (* tycon mismatch *)      | TYC of Types.tycon * Types.tycon (* tycon mismatch *)
11      | TYP of Types.ty * Types.ty (* type mismatch *)      | TYP of Types.ty * Types.ty (* type mismatch *)
12      | LIT of Types.tvKind (* literal *)      | LIT of Types.tvKind (* literal *)
13        | OVLD of Types.ty (* overload scheme *)
14      | UBVE of Types.tvKind (* UBOUND, equality mismatch *)      | UBVE of Types.tvKind (* UBOUND, equality mismatch *)
15      | UBV of Types.tvKind (* UBOUND match *)      | UBV of Types.tvKind (* UBOUND match *)
16      | SCH (* SCHEME, equality mismatch  *)      | SCH (* SCHEME, equality mismatch  *)
# Line 56  Line 57 
57    | TYC of Types.tycon * Types.tycon (* tycon mismatch *)    | TYC of Types.tycon * Types.tycon (* tycon mismatch *)
58    | TYP of Types.ty * Types.ty (* type mismatch *)    | TYP of Types.ty * Types.ty (* type mismatch *)
59    | LIT of Types.tvKind (* literal *)    | LIT of Types.tvKind (* literal *)
60      | OVLD of Types.ty (* overload scheme *)
61    | UBVE of Types.tvKind (* UBOUND, equality mismatch *)    | UBVE of Types.tvKind (* UBOUND, equality mismatch *)
62    | UBV of Types.tvKind (* UBOUND match *)    | UBV of Types.tvKind (* UBOUND match *)
63    | SCH (* SCHEME, equality mismatch  *)    | SCH (* SCHEME, equality mismatch  *)
# Line 68  Line 70 
70         | TYC(tyc1,tyc2) => "tycon mismatch"         | TYC(tyc1,tyc2) => "tycon mismatch"
71         | TYP(ty1,ty2) => "type mismatch"         | TYP(ty1,ty2) => "type mismatch"
72         | LIT(info) => "literal"         | LIT(info) => "literal"
73           | OVLD(info) => "overload"
74         | UBVE(info) => "UBOUND, equality mismatch"         | UBVE(info) => "UBOUND, equality mismatch"
75         | UBV(info) => "UBOUND match"         | UBV(info) => "UBOUND match"
76         | SCH => "SCHEME, equality mismatch"         | SCH => "SCHEME, equality mismatch"
# Line 373  Line 376 
376         var := INSTANTIATED ty)         var := INSTANTIATED ty)
377    
378    | instTyvar (var as ref(OPEN{kind=FLEX fields,depth,eq}),ty) =    | instTyvar (var as ref(OPEN{kind=FLEX fields,depth,eq}),ty) =
379        let val ty' = readReduceType ty (* try to reduce to a record type *)        let val ty' = TU.headReduceType ty (* try to reduce to a record type *)
380         in case ty'         in case ty'
381             of CONty(RECORDtyc field_names, field_types) =>             of CONty(RECORDtyc field_names, field_types) =>
382                  let val record_fields = ListPair.zip (field_names,field_types)                  let val record_fields = ListPair.zip (field_names,field_types)
# Line 387  Line 390 
390        end        end
391    
392    | instTyvar (var as ref(i as SCHEME eq),ty) =    | instTyvar (var as ref(i as SCHEME eq),ty) =
393        let val ty' = readReduceType ty        let val ty' = TU.headReduceType ty
394         in case ty'         in case ty'
395              of VARty var1 => unifyTyvars(var, var1)              of VARty var1 => unifyTyvars(var, var1)
396               | _ => adjustType(var,infinity,eq,ty');               | CONty(tyc,nil) => var := INSTANTIATED ty'
397            var := INSTANTIATED ty'                   (* valid potential resolution type. Could check
398                      * for membership in allowed basic types (e.g. int, real, ...) *)
399                 | _ => raise Unify(OVLD ty')
400        end        end
401    
402    | instTyvar (var as ref(i as LITERAL{kind,...}),ty) =    | instTyvar (var as ref(i as LITERAL{kind,...}),ty) =
403        (case headReduceType ty        (case TU.headReduceType ty
404           of WILDCARDty => ()           of WILDCARDty => ()
405            | ty' =>            | ty' =>
406               if OLL.isLiteralTy(kind,ty')               if OLL.isLiteralTy(kind,ty')
# Line 407  Line 412 
412           of WILDCARDty => ()           of WILDCARDty => ()
413            | _ =>  raise Unify (UBV i))   (* could return the ty for error msg*)            | _ =>  raise Unify (UBV i))   (* could return the ty for error msg*)
414    
415    | instTyvar (ref(INSTANTIATED _),_,_) = bug "instTyvar: INSTANTIATED"    | instTyvar (ref(INSTANTIATED _),_) = bug "instTyvar: INSTANTIATED"
416    | instTyvar (ref(LBOUND _),_,_) = bug "instTyvar: LBOUND"    | instTyvar (ref(LBOUND _),_) = bug "instTyvar: LBOUND"
417    
418  (*  (*
419   * merge_fields(extra1,extra2,fields1,fields2):   * merge_fields(extra1,extra2,fields1,fields2):
# Line 430  Line 435 
435    
436  end (* local *)  end (* local *)
437  end (* structure Unify *)  end (* structure Unify *)
   
Legend:
Removed from v.2530  
changed lines
  Added in v.2531
root@smlnj-gforge.cs.uchicago.edu
 ViewVC Help
Powered by ViewVC 1.0.0  
Powered By FusionForge