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-2/src/compiler/ElabData/types/typesutil.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-2/src/compiler/ElabData/types/typesutil.sml

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

revision 1960, Fri Jul 7 20:38:45 2006 UTC revision 1961, Fri Jul 7 21:06:11 2006 UTC
# Line 76  Line 76 
76   * variable), use mkMETAtyBounded with the appropriate depth.   * variable), use mkMETAtyBounded with the appropriate depth.
77   *)   *)
78    
79  fun mkMETAtyBounded depth : ty = VARty(mkTyvar (mkMETA depth))  fun mkMETAtyBounded (depth: int) : ty = VARty(mkTyvar (mkMETA depth))
80    
81  fun mkMETAty() = mkMETAtyBounded infinity  fun mkMETAty() = mkMETAtyBounded infinity
82    
# Line 332  Line 332 
332      end      end
333    
334  fun dconType (tyc,domain) =  fun dconType (tyc,domain) =
335      let val arity = tyconArity tyc      (case tyconArity tyc
336      in        of 0 => (case domain
337          case arity of                   of NONE => CONty(tyc,[])
             0 => (case domain of  
                       NONE => CONty(tyc,[])  
338                      | SOME dom => dom --> CONty(tyc,[]))                      | SOME dom => dom --> CONty(tyc,[]))
339            | _ =>         | arity =>
340              POLYty{sign=mkPolySign arity,              POLYty{sign=mkPolySign arity,
341                     tyfun=TYFUN{arity=arity,                     tyfun=TYFUN{arity=arity,
342                                 body = case domain of                              body = case domain
343                                            NONE => CONty(tyc,boundargs(arity))                                       of NONE => CONty(tyc,boundargs(arity))
344                                          | SOME dom =>                                          | SOME dom =>
345                                            dom --> CONty(tyc,boundargs(arity))}}                                          dom --> CONty(tyc,boundargs(arity))}})
     end  
346    
347  (* matching a scheme against a target type -- used declaring overloadings *)  (* matching a scheme against a target type -- used declaring overloadings *)
348  fun matchScheme (TYFUN{arity,body}: tyfun, target: ty) : ty =  fun matchScheme (TYFUN{arity,body}: tyfun, target: ty) : ty =
# Line 455  Line 452 
452          true          true
453      end      end
454      handle CHECKEQ => false      handle CHECKEQ => false
455    
456    fun checkEqTyInst(ty) =
457        let fun eqty(VARty(ref(INSTANTIATED ty))) = eqty ty
458              | eqty(VARty(ref(OPEN{eq,...}))) = if eq then () else raise CHECKEQ
459              | eqty(CONty(DEFtyc{tyfun,...}, args)) =
460                  eqty(applyTyfun(tyfun,args))
461              | eqty(CONty(GENtyc { eq, ... }, args)) =
462                 (case !eq
463                    of OBJ => ()
464                     | YES => app eqty args
465                     | (NO | ABS | IND) => raise CHECKEQ
466                     | p => bug ("checkEqTyInst: "^eqpropToString p))
467              | eqty(CONty(RECORDtyc _, args)) = app eqty args
468              | eqty(IBOUND n) = bug "checkEqTyInst: IBOUND in instantiated polytype"
469              | eqty _ = () (* what other cases? dbm *)
470         in eqty ty;
471            true
472        end
473        handle CHECKEQ => false
474  end  end
475    
476  (* compType, compareTypes used to compare specification type with type of  (* compType, compareTypes used to compare specification type with type of
# Line 472  Line 488 
488                      (let val eq = List.nth(actsign,i)                      (let val eq = List.nth(actsign,i)
489                        in if eq andalso not(checkEqTySig(ty1,specsign))                        in if eq andalso not(checkEqTySig(ty1,specsign))
490                           then raise CompareTypes                           then raise CompareTypes
491                           else ();                           else update(env,i,ty1)
                          update(env,i,ty1)  
492                       end handle Subscript => ())                       end handle Subscript => ())
493                   | ty => if equalType(ty1,ty)                   | ty => if equalType(ty1,ty)
494                           then ()                           then ()
# Line 496  Line 511 
511                   of POLYty{sign=sign',tyfun=TYFUN{arity,body=body'}} =>                   of POLYty{sign=sign',tyfun=TYFUN{arity,body=body'}} =>
512                        (compType(body,sign,body',sign',arity); true)                        (compType(body,sign,body',sign',arity); true)
513                    | WILDCARDty => true                    | WILDCARDty => true
514                    | _ => false)                    | _ => false) (* if spec is poly, then actual must be poly *)
515             | WILDCARDty => true             | WILDCARDty => true
516             | _ =>             | _ => (* spec is a monotype *)
517                (case actual                (case actual
518                   of POLYty{sign,tyfun=TYFUN{arity,body}} =>                   of POLYty{sign,tyfun=TYFUN{arity,body}} =>
519                        (compType(spec,[],body,sign,arity); true)                        (compType(spec,[],body,sign,arity); true)
# Line 525  Line 540 
540               matchTypes.               matchTypes.
541    
542     matchTypes is used in SigMatch for matching structures (matchStr1) only     matchTypes is used in SigMatch for matching structures (matchStr1) only
543    
544       dbm:This doesn't work. After instantiating spec and actual, have to do
545         a one-way match of spec (specinst) against (more general) actual (actinst),
546         and this match should instantiate the tyvars in actParamTvs to capture
547         the parameters that instantiate actual to produce specinst.
548   *)   *)
549    (*
550  fun matchTypes (specTy, actualTy) =  fun matchTypes (specTy, actualTy) =
551      (* If specTy is an instance of actualTy,      (* If specTy is an instance of actualTy,
552         then match, otherwise give up. *)         then match, otherwise give up. *)
# Line 541  Line 562 
562              (specGenericTvs, actParamTvs)              (specGenericTvs, actParamTvs)
563          end          end
564      else ([], [])      else ([], [])
565    *)
566    (* matchInstTypes: ty * ty -> (tyvar list * tyvar list) option
567     * The first argument is a spec type (e.g. from a signature spec),
568     * while the second is a potentially more general actual type. The
569     * two types are instantiated (if they are polymorphic), and a one-way
570     * match is performed on their generic instantiations.
571     * [Note that the match cannot succeed if spec is polymorphic while
572     * actualTy is monomorphic.]
573     * This function is also used more generally to obtain instantiation
574     * parameters for a polytype (actualTy) to obtain one of its instantiations
575     * (specTy). This usage occurs in translate.sml where we match an occurrence
576     * type of a primop variable with the intrinsic type of the primop to obtain
577     * the parameters of instantiation of the primop.
578     *)
579    fun matchInstTypes(specTy,actualTy) =
580        let fun match'(WILDCARDty, _) = () (* possible? how? *)
581              | match'(_, WILDCARDty) = () (* possible? how? *)
582              | match'(ty1, VARty(tv as ref(OPEN{kind=META,eq,...})) =
583                  if eq andalso not(checkEqTyInst(ty1))
584                  then raise CompareTypes
585                  else tv := INSTANTIATED ty1
586              | match'(ty1, VARty(tv as ref(INSTANTIATED ty2)) =
587                  if equalType(ty1,ty2) then () else raise CompareTypes
588              | match'(CONty(tycon1, args1), CONty(tycon2, args2)) =
589                  if eqTycon(tycon1,tycon2)
590                  then ListPair.app match (args1,args2)
591                  else raise CompareTypes
592              | match' _ = raise CompareTypes
593            and match(ty1,ty2) = match'(headReduceType ty1, headReduceType ty2)
594            val (actinst, actParamTvs) = instantiatePoly actualTy
595            val (specinst, specGenericTvs) = instantiatePoly specTy
596        in match(specinst,actinst);
597           SOME(specGenericTvs, actParamTvs)
598        end handle CompareTypes => NONE
599    
600  (* given a single-type-variable type, extract out the tyvar *)  (* given a single-type-variable type, extract out the tyvar *)
601  fun tyvarType (VARty (tv as ref(OPEN _))) = tv  fun tyvarType (VARty (tv as ref(OPEN _))) = tv
# Line 556  Line 611 
611   * getRecTyvarMap : int * ty -> (int -> bool)   * getRecTyvarMap : int * ty -> (int -> bool)
612   * see if a bound tyvar has occurred in some datatypes, e.g. 'a list.   * see if a bound tyvar has occurred in some datatypes, e.g. 'a list.
613   * this is useful for representation analysis. This function probably   * this is useful for representation analysis. This function probably
614   * will soon be obsolete.   * will soon be obsolete (dbm: Why?).
615   *)   *)
616  fun getRecTyvarMap (n,ty) =  fun getRecTyvarMap (n,ty) =
617      let val s = Array.array(n,false)      let val s = Array.array(n,false)
# Line 622  Line 677 
677    | isValue (APPexp(rator, rand)) =    | isValue (APPexp(rator, rand)) =
678      let fun isrefdcon(DATACON{rep=A.REF,...}) = true      let fun isrefdcon(DATACON{rep=A.REF,...}) = true
679            | isrefdcon _ = false            | isrefdcon _ = false
680          fun iscast (VALvar { info, ... }) = InlInfo.isPrimCast info          fun iscast (VALvar {prim, ...}) = PrimOpId.isPrimCast prim
681            | iscast _ = false            | iscast _ = false
682    
683          (* LAZY: The following function allows applications of the          (* LAZY: The following function allows applications of the
# Line 930  Line 985 
985          of SOME tyc' => unWrapDefStar tyc'          of SOME tyc' => unWrapDefStar tyc'
986           | NONE => tyc)           | NONE => tyc)
987    
988    (* dummyTyGen produces a generator of dummy types with names X0, X1, etc.
989     * These are used to to instantiate type metavariables in top-level val
990     * decls that are not generalized because of the value restriction. *)
991  fun dummyTyGen () : unit -> Types.ty =  fun dummyTyGen () : unit -> Types.ty =
992      let val count = ref 0      let val count = ref 0
993          fun next () = (count := !count + 1; !count)          fun next () = (count := !count + 1; !count)

Legend:
Removed from v.1960  
changed lines
  Added in v.1961

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