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
 [smlnj] / sml / branches / primop-branch-2 / src / compiler / ElabData / types / typesutil.sml

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

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
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