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

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

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

revision 1474, Sun Apr 4 21:29:18 2004 UTC revision 1475, Fri Apr 9 19:05:33 2004 UTC
# Line 457  Line 457 
457      handle CHECKEQ => false      handle CHECKEQ => false
458  end  end
459    
460    (* compType, compareTypes used to compare specification type with type of
461     * corresponding actual element.  Check that spec type is an instance of
462     * the actual type *)
463  exception CompareTypes  exception CompareTypes
464  fun compType(specty, specsign:polysign, actty,  fun compType(specty, specsign:polysign, actty,
465               actsign:polysign, actarity): unit =               actsign:polysign, actarity): unit =
466      let val env = array(actarity,UNDEFty)      let val env = array(actarity,UNDEFty) (* instantiations of IBOUNDs in actual body *)
467          fun comp'(WILDCARDty, _) = ()          fun comp'(WILDCARDty, _) = ()
468            | comp'(_, WILDCARDty) = ()            | comp'(_, WILDCARDty) = ()
469            | comp'(ty1, IBOUND i) =            | comp'(ty1, IBOUND i) =
# Line 484  Line 487 
487       in comp(specty,actty)       in comp(specty,actty)
488      end      end
489    
490  (* returns true if actual type > spec type *)  (* returns true if actual type > spec type, i.e. if spec is an instance of actual *)
491  fun compareTypes (spec : ty, actual: ty): bool =  fun compareTypes (spec : ty, actual: ty): bool =
492      let val actual = prune actual      let val actual = prune actual
493       in case spec       in case spec
# Line 561  Line 564 
564     be nonexpansive. (Taha, DBM) *)     be nonexpansive. (Taha, DBM) *)
565  local open Absyn in  local open Absyn in
566    
567  fun isValue { ii_ispure } = let  fun isValue (VARexp _) = true
568      fun isval (VARexp _) = true    | isValue (CONexp _) = true
569        | isval (CONexp _) = true    | isValue (INTexp _) = true
570        | isval (INTexp _) = true    | isValue (WORDexp _) = true
571        | isval (WORDexp _) = true    | isValue (REALexp _) = true
572        | isval (REALexp _) = true    | isValue (STRINGexp _) = true
573        | isval (STRINGexp _) = true    | isValue (CHARexp _) = true
574        | isval (CHARexp _) = true    | isValue (FNexp _) = true
575        | isval (FNexp _) = true    | isValue (RECORDexp fields) =
576        | isval (RECORDexp fields) =      foldr (fn ((_,exp),x) => x andalso (isValue exp)) true fields
577          foldr (fn ((_,exp),x) => x andalso (isval exp)) true fields    | isValue (SELECTexp(_, e)) = isValue e
578        | isval (SELECTexp(_, e)) = isval e    | isValue (VECTORexp (exps, _)) =
579        | isval (VECTORexp (exps, _)) =      foldr (fn (exp,x) => x andalso (isValue exp)) true exps
580          foldr (fn (exp,x) => x andalso (isval exp)) true exps    | isValue (SEQexp nil) = true
581        | isval (SEQexp nil) = true    | isValue (SEQexp [e]) = isValue e
582        | isval (SEQexp [e]) = isval e    | isValue (SEQexp _) = false
583        | isval (SEQexp _) = false    | isValue (APPexp(rator, rand)) =
       | isval (APPexp(rator, rand)) =  
584          let fun isrefdcon(DATACON{rep=A.REF,...}) = true          let fun isrefdcon(DATACON{rep=A.REF,...}) = true
585                | isrefdcon _ = false                | isrefdcon _ = false
586            fun iscast (VALvar { info, ... }) = InlInfo.pureInfo info
587              | iscast _ = false
588            (* -- parameterized by ii_ispure, which will be bound to InlInfo.pureInfo
589              fun iscast (VALvar { info, ... }) = ii_ispure info              fun iscast (VALvar { info, ... }) = ii_ispure info
590                | iscast _ = false                | iscast _ = false
591            *)
592              (*              (*
593              fun iscast(VALvar{info,...}) = II.pureInfo (II.fromExn info)              fun iscast(VALvar{info,...}) = II.pureInfo (II.fromExn info)
594                | iscast _ = false                | iscast _ = false
# Line 601  Line 607 
607                | iscon (MARKexp(e,_)) = iscon e                | iscon (MARKexp(e,_)) = iscon e
608                | iscon (VARexp(ref v, _)) = (iscast v) orelse (issafe v)                | iscon (VARexp(ref v, _)) = (iscast v) orelse (issafe v)
609                | iscon _ = false                | iscon _ = false
610          in if iscon rator then isval rand      in if iscon rator then isValue rand
611             else false             else false
612          end          end
613        | isval (CONSTRAINTexp(e,_)) = isval e    | isValue (CONSTRAINTexp(e,_)) = isValue e
614        | isval (CASEexp(e, (RULE(p,_))::_, false)) =    | isValue (CASEexp(e, (RULE(p,_))::_, false)) =
615          (isval e) andalso (irref p) (* special bind CASEexps *)      (isValue e) andalso (irref p) (* special bind CASEexps *)
616        | isval (LETexp(VALRECdec _, e)) = (isval e) (* special RVB hacks *)    | isValue (LETexp(VALRECdec _, e)) = (isValue e) (* special RVB hacks *)
617        | isval (MARKexp(e,_)) = isval e    | isValue (MARKexp(e,_)) = isValue e
618        | isval _ = false    | isValue _ = false
 in  
     isval  
 end  
619    
620  (* testing if a binding pattern is irrefutable --- complete *)  (* testing if a binding pattern is irrefutable --- complete *)
621  and irref pp  =  and irref pp  =

Legend:
Removed from v.1474  
changed lines
  Added in v.1475

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