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/FLINT/trans/translate.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml

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

revision 879, Thu Jul 19 18:59:38 2001 UTC revision 902, Wed Aug 15 21:17:05 2001 UTC
# Line 6  Line 6 
6    
7    (* Invariant: transDec always applies to a top-level absyn declaration *)    (* Invariant: transDec always applies to a top-level absyn declaration *)
8    val transDec : Absyn.dec * Access.lvar list    val transDec : Absyn.dec * Access.lvar list
9                   * StaticEnv.staticEnv * CompInfo.compInfo                   * StaticEnv.staticEnv * Absyn.dec CompInfo.compInfo
10                   -> {flint: FLINT.prog,                   -> {flint: FLINT.prog,
11                       imports: (PersStamps.persstamp                       imports: (PersStamps.persstamp
12                                 * ImportTree.importTree) list}                                 * ImportTree.importTree) list}
# Line 97  Line 97 
97   *                               * ImportTree.importTree) list}             *   *                               * ImportTree.importTree) list}             *
98   ****************************************************************************)   ****************************************************************************)
99    
100  fun transDec (rootdec, exportLvars, env,  fun transDec
101                compInfo as {errorMatch,error,...}: CompInfo.compInfo) =          (rootdec, exportLvars, env,
102             compInfo as {errorMatch,error,...}: Absyn.dec CompInfo.compInfo) =
103  let  let
104    
105  (** generate the set of ML-to-FLINT type translation functions *)  (** generate the set of ML-to-FLINT type translation functions *)
106  val {tpsKnd, tpsTyc, toTyc, toLty, strLty, fctLty} = TT.genTT()  val {tpsKnd, tpsTyc, toTyc, toLty, strLty, fctLty, markLBOUND} =
107        TT.genTT()
108  fun toTcLt d = (toTyc d, toLty d)  fun toTcLt d = (toTyc d, toLty d)
109    
110  (** translating the typ field in DATACON into lty; constant datacons  (** translating the typ field in DATACON into lty; constant datacons
# Line 735  Line 737 
737        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)
738    | mkVar _ = bug "unexpected vars in mkVar"    | mkVar _ = bug "unexpected vars in mkVar"
739    
740  fun mkVE (v as V.VALvar {info=II.INL_PRIM(p, typ), ...}, ts, d) =  fun mkVE (v, ts, d) = let
741        (case (p, ts)      fun otherwise () =
742          of (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)          case ts of
743           | (PO.POLYNEQ, [t]) => composeNOT(eqGen(typ, t, toTcLt d), toLty d t)              [] => mkVar (v, d)
744              | _ => TAPP(mkVar(v, d), map (toTyc d) ts)
745    in
746        case v of
747            V.VALvar { info, ... } =>
748            II.match info
749               { inl_prim = fn (p, typ) =>
750                 (case (p, ts) of
751                      (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)
752                    | (PO.POLYNEQ, [t]) =>
753                      composeNOT(eqGen(typ, t, toTcLt d), toLty d t)
754           | (PO.INLMKARRAY, [t]) =>           | (PO.INLMKARRAY, [t]) =>
755                  let val dict =                  let val dict =
756                        {default = coreAcc "mkNormArray",                        {default = coreAcc "mkNormArray",
# Line 752  Line 764 
764                     handle CProto.BadEncoding => NONE                     handle CProto.BadEncoding => NONE
765              in PRIM (PO.RAW_CCALL i, toLty d typ, map (toTyc d) ts)              in PRIM (PO.RAW_CCALL i, toLty d typ, map (toTyc d) ts)
766             end             end
767           | _ => transPrim(p, (toLty d typ), map (toTyc d) ts))                  | _ => transPrim(p, (toLty d typ), map (toTyc d) ts)),
768    | mkVE (v, [], d) = mkVar(v, d)               inl_str = fn _ => otherwise (),
769    | mkVE (v, ts, d) = TAPP(mkVar(v, d), map (toTyc d) ts)               inl_no = fn () => otherwise () }
770          | _ => otherwise ()
771    end
772    
773  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
774    let val lt = toDconLty d typ    let val lt = toDconLty d typ
# Line 807  Line 821 
821        let val savedtvs = map ! boundtvs        let val savedtvs = map ! boundtvs
822    
823            fun g (i, []) = ()            fun g (i, []) = ()
824              | g (i, (tv as ref (TP.OPEN _))::rest) =              | g (i, (tv as ref (TP.OPEN _))::rest) = let
825                     (tv := TP.LBOUND{depth=d, num=i}; g(i+1,rest))                    val m = markLBOUND (d, i);
826              | g (i, (tv as ref (TP.LBOUND _))::res) =                in
827                     bug ("unexpected tyvar LBOUND in mkPE")                    tv := TP.TV_MARK m;
828                      g (i+1, rest)
829                  end
830                | g (i, (tv as ref (TP.TV_MARK _))::res) =
831                       bug ("unexpected tyvar TV_MARK in mkPE")
832              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"
833    
834            val _ = g(0, boundtvs) (* assign the LBOUND tyvars *)            val _ = g(0, boundtvs) (* assign the TV_MARK tyvars *)
835            val exp' = mkExp(exp, DI.next d)            val exp' = mkExp(exp, DI.next d)
836    
837            fun h ([], []) = ()            fun h ([], []) = ()

Legend:
Removed from v.879  
changed lines
  Added in v.902

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