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

Diff of /sml/trunk/src/compiler/FLINT/trans/translate.sml

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

revision 102, Thu May 14 05:53:10 1998 UTC revision 592, Mon Apr 3 07:04:12 2000 UTC
# Line 77  Line 77 
77    
78  (** sorting the record fields for record types and record expressions *)  (** sorting the record fields for record types and record expressions *)
79  fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)  fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)
80  fun sorted x = Sort.sorted elemgtr x  fun sorted x = ListMergeSort.sorted elemgtr x
81  fun sortrec x = Sort.sort elemgtr x  fun sortrec x = ListMergeSort.sort elemgtr x
82    
83  (** check if an access is external *)  (** check if an access is external *)
84  fun extern (DA.EXTERN _) = true  fun extern (DA.EXTERN _) = true
# Line 99  Line 99 
99   ****************************************************************************)   ****************************************************************************)
100    
101  fun transDec (rootdec, exportLvars, env,  fun transDec (rootdec, exportLvars, env,
102                compInfo as {coreEnv,errorMatch,error,...}: CB.compInfo) =                compInfo as {errorMatch,error,...}: CB.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 *)
# Line 120  Line 120 
120    
121  (** the special lookup functions for the Core environment *)  (** the special lookup functions for the Core environment *)
122  fun coreLookup(id, env) =  fun coreLookup(id, env) =
123    let val sp = SymPath.SPATH [S.strSymbol "Core", S.varSymbol id]    let val sp = SymPath.SPATH [CoreSym.coreSym, S.varSymbol id]
124        val err = fn _ => fn _ => fn _ => raise NoCore        val err = fn _ => fn _ => fn _ => raise NoCore
125     in Lookup.lookVal(env, sp, err)     in Lookup.lookVal(env, sp, err)
126    end    end
127    
128  fun CON' ((_, DA.REF, lt), ts, e) = APP (PRIM (PO.MAKEREF, lt, ts), e)  fun CON' ((_, DA.REF, lt), ts, e) = APP (PRIM (PO.MAKEREF, lt, ts), e)
129    | CON' ((_, DA.SUSP (SOME(DA.LVAR d, _)), lt), ts, e) =    | CON' ((_, DA.SUSP (SOME(DA.LVAR d, _)), lt), ts, e) =
130       if !Control.Lazy.earlyDT        let val v   = mkv ()
      then bug "DA.SUSP in Translate.CON' while earlyDT is true."  
      else let val v   = mkv ()  
131                val fe = FN (v, LT.ltc_tuple [], e)                val fe = FN (v, LT.ltc_tuple [], e)
132             in APP(TAPP (VAR d, ts), fe)             in APP(TAPP (VAR d, ts), fe)
133            end            end
# Line 161  Line 159 
159    
160  fun complain s = error (!region) s  fun complain s = error (!region) s
161  fun repErr x = complain EM.COMPLAIN x EM.nullErrorBody  fun repErr x = complain EM.COMPLAIN x EM.nullErrorBody
162    fun repPolyEq () =
163        if !Control.polyEqWarn then complain EM.WARN "calling polyEqual" EM.nullErrorBody
164        else ()
165    
166  end (* markexn-local *)  end (* markexn-local *)
167    
# Line 239  Line 240 
240  val persmap = ref (Map.empty : pidInfo Map.map)  val persmap = ref (Map.empty : pidInfo Map.map)
241    
242  fun mkPid (pid, t, l, nameOp) =  fun mkPid (pid, t, l, nameOp) =
243    (let val pinfo = Map.lookup (!persmap) pid      case Map.find (!persmap, pid)
244         val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)        of NONE =>
     in persmap := Map.add(Map.delete(pid, !persmap), pid, npinfo); var  
    end handle Map.MapF =>  
245           let val (pinfo, var) = mkPidInfo (t, l, nameOp)           let val (pinfo, var) = mkPidInfo (t, l, nameOp)
246            in persmap := Map.add(!persmap, pid, pinfo); var             in persmap := Map.insert(!persmap, pid, pinfo);
247           end)                var
248              end
249           | SOME pinfo =>
250              let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)
251                  fun rmv (key, map) =
252                      let val (newMap, _) = Map.remove(map, key)
253                      in newMap
254                      end handle e => map
255               in persmap := Map.insert(rmv(pid, !persmap), pid, npinfo);
256                  var
257              end
258    
259  (** converting an access w. type into a lambda expression *)  (** converting an access w. type into a lambda expression *)
260  fun mkAccT (p, t, nameOp) =  fun mkAccT (p, t, nameOp) =
# Line 273  Line 282 
282   * the primitive environment. (ZHONG)   * the primitive environment. (ZHONG)
283   *)   *)
284  fun coreExn id =  fun coreExn id =
285    ((case coreLookup(id, coreEnv)    ((case coreLookup(id, env)
286       of V.CON(TP.DATACON{name, rep as DA.EXN _, typ, ...}) =>       of V.CON(TP.DATACON{name, rep as DA.EXN _, typ, ...}) =>
287            let val nt = toDconLty DI.top typ            let val nt = toDconLty DI.top typ
288                val nrep = mkRep(rep, nt, name)                val nrep = mkRep(rep, nt, name)
# Line 283  Line 292 
292     handle NoCore => (say "WARNING: no Core access \n"; INT 0))     handle NoCore => (say "WARNING: no Core access \n"; INT 0))
293    
294  and coreAcc id =  and coreAcc id =
295    ((case coreLookup(id, coreEnv)    ((case coreLookup(id, env)
296       of V.VAL(V.VALvar{access, typ, path, ...}) =>       of V.VAL(V.VALvar{access, typ, path, ...}) =>
297             mkAccT(access, toLty DI.top (!typ), getNameOp path)             mkAccT(access, toLty DI.top (!typ), getNameOp path)
298        | _ => bug "coreAcc in translate")        | _ => bug "coreAcc in translate")
# Line 349  Line 358 
358              end              end
359          | fill (VECTORpat(pats,ty)) = VECTORpat(map fill pats, ty)          | fill (VECTORpat(pats,ty)) = VECTORpat(map fill pats, ty)
360          | fill (ORpat(p1, p2)) = ORpat(fill p1, fill p2)          | fill (ORpat(p1, p2)) = ORpat(fill p1, fill p2)
361          | fill (CONpat(TP.DATACON{name, const, typ, rep, sign}, ts)) =          | fill (CONpat(TP.DATACON{name, const, typ, rep, sign, lazyp}, ts)) =
362              CONpat(TP.DATACON{name=name, const=const, typ=typ,              CONpat(TP.DATACON{name=name, const=const, typ=typ, lazyp=lazyp,
363                          sign=sign, rep=mkRep(rep, toDconLty d typ, name)}, ts)                          sign=sign, rep=mkRep(rep, toDconLty d typ, name)}, ts)
364          | fill (APPpat(TP.DATACON{name, const, typ, rep, sign}, ts, pat)) =          | fill (APPpat(TP.DATACON{name, const, typ, rep, sign, lazyp}, ts, pat)) =
365              APPpat(TP.DATACON{name=name, const=const, typ=typ, sign=sign,              APPpat(TP.DATACON{name=name, const=const, typ=typ, sign=sign, lazyp=lazyp,
366                         rep=mkRep(rep, toDconLty d typ, name)}, ts, fill pat)                         rep=mkRep(rep, toDconLty d typ, name)}, ts, fill pat)
367          | fill xp = xp          | fill xp = xp
368    
# Line 373  Line 382 
382                        end))                        end))
383    
384        fun getPolyEq () =        fun getPolyEq () =
385          (case (!polyEqRef)          (repPolyEq();
386             case (!polyEqRef)
387            of SOME e => e            of SOME e => e
388             | NONE => (let val e = coreAcc "polyequal"             | NONE => (let val e = coreAcc "polyequal"
389                         in polyEqRef := (SOME e); e                         in polyEqRef := (SOME e); e
# Line 686  Line 696 
696                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))
697                end                end
698    
699    (**** ASSIGN(r, x) <> UPDATE(r, 0, x) under new array reps (JHR;1998-10-30)
700          | g (PO.ASSIGN) =          | g (PO.ASSIGN) =
701                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
702                                      | _ => bug "unexpected ty for ASSIGN"                                      | _ => bug "unexpected ty for ASSIGN"
# Line 701  Line 712 
712                 in FN(x, argt,                 in FN(x, argt,
713                     APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))                     APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))
714                end                end
715    ****)
716    
717          | g p = PRIM(p, lt, ts)          | g p = PRIM(p, lt, ts)
718    
# Line 908  Line 920 
920    
921  and mkFctexp (fe, d) =  and mkFctexp (fe, d) =
922    let fun g (VARfct f) = mkFct(f, d)    let fun g (VARfct f) = mkFct(f, d)
923          | g (FCTfct{param as M.STR{access=DA.LVAR v, ...}, argtycs, def}) =          | g (FCTfct {param as M.STR { access, ... }, argtycs, def }) =
924              (case access of
925                   DA.LVAR v =>
926                let val knds = map tpsKnd argtycs                let val knds = map tpsKnd argtycs
927                    val nd = DI.next d                    val nd = DI.next d
928                    val body = mkStrexp (def, nd)                    val body = mkStrexp (def, nd)
929                    val hdr = buildHdr v                    val hdr = buildHdr v
930                    (* binding of all v's components *)                    (* binding of all v's components *)
931                 in TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))                 in
932                       TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))
933                end                end
934                 | _ => bug "mkFctexp: unexpected access")
935          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)
936          | g (MARKfct (b, reg)) = withRegion reg g b          | g (MARKfct (b, reg)) = withRegion reg g b
937          | g _ = bug "unexpected functor expressions in mkFctexp"          | g _ = bug "unexpected functor expressions in mkFctexp"
# Line 924  Line 940 
940    end    end
941    
942  and mkStrbs (sbs, d) =  and mkStrbs (sbs, d) =
943    let fun g (STRB{str=M.STR{access=DA.LVAR v, ...}, def, ...}, b) =    let fun g (STRB{str=M.STR { access, ... }, def, ... }, b) =
944              (case access of
945                   DA.LVAR v =>
946                 let val hdr = buildHdr v                 let val hdr = buildHdr v
947                     (* binding of all v's components *)                     (* binding of all v's components *)
948                  in LET(v, mkStrexp(def, d), hdr b)                 in
949                       LET(v, mkStrexp(def, d), hdr b)
950                 end                 end
951                 | _ => bug "mkStrbs: unexpected access")
952          | g _ = bug "unexpected structure bindings in mkStrbs"          | g _ = bug "unexpected structure bindings in mkStrbs"
   
953     in fold g sbs     in fold g sbs
954    end    end
955    
956  and mkFctbs (fbs, d) =  and mkFctbs (fbs, d) =
957    let fun g (FCTB{fct=M.FCT{access=DA.LVAR v, ...}, def, ...}, b) =    let fun g (FCTB{fct=M.FCT { access, ... }, def, ... }, b) =
958              (case access of
959                   DA.LVAR v =>
960                 let val hdr = buildHdr v                 let val hdr = buildHdr v
961                  in LET(v, mkFctexp(def, d), hdr b)                 in
962                       LET(v, mkFctexp(def, d), hdr b)
963                 end                 end
964                 | _ => bug "mkFctbs: unexpected access")
965          | g _ = bug "unexpected functor bindings in mkStrbs"          | g _ = bug "unexpected functor bindings in mkStrbs"
   
966     in fold g fbs     in fold g fbs
967    end    end
968    
# Line 1153  Line 1173 
1173  val body = mkDec (rootdec, DI.top) exportLexp  val body = mkDec (rootdec, DI.top) exportLexp
1174    
1175  (** wrapping up the body with the imported variables *)  (** wrapping up the body with the imported variables *)
1176  val (plexp, imports) = wrapPidInfo (body, Map.members (!persmap))  val (plexp, imports) = wrapPidInfo (body, Map.listItemsi (!persmap))
1177    
1178  fun prGen (flag,printE) s e =  fun prGen (flag,printE) s e =
1179    if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else ()    if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else ()
1180  val _ = prGen(Control.CG.printFlint, PPLexp.printLexp) "Translate" plexp  val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp
1181    
1182  (** normalizing the plambda expression into FLINT *)  (** normalizing the plambda expression into FLINT *)
1183  val flint = FlintNM.norm plexp  val flint = FlintNM.norm plexp
# Line 1169  Line 1189 
1189  end (* structure Translate *)  end (* structure Translate *)
1190    
1191    
 (*  
  * $Log: translate.sml,v $  
  * Revision 1.1.1.1  1998/04/08 18:39:40  george  
  * Version 110.5  
  *  
  *)  

Legend:
Removed from v.102  
changed lines
  Added in v.592

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