SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/FLINT/trans/translate.sml

[smlnj] / sml / trunk / src / compiler / FLINT / trans / translate.sml

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

-revision 102, Thu May 14 05:53:10 1998 UTC
+revision 592, Mon Apr  3 07:04:12 2000 UTC
 Line 77
  (** sorting the record fields for record types and record expressions *)
  fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)
- fun sorted x = Sort.sorted elemgtr x
+ fun sorted x = ListMergeSort.sorted elemgtr x
- fun sortrec x = Sort.sort elemgtr x
+ fun sortrec x = ListMergeSort.sort elemgtr x
  (** check if an access is external *)
  fun extern (DA.EXTERN _) = true
 Line 99
   ****************************************************************************)
  fun transDec (rootdec, exportLvars, env,
-               compInfo as {coreEnv,errorMatch,error,...}: CB.compInfo) =
+               compInfo as {errorMatch,error,...}: CB.compInfo) =
  let
  (** generate the set of ML-to-FLINT type translation functions *)
 Line 120
  (** the special lookup functions for the Core environment *)
  fun coreLookup(id, env) =
-   let val sp = SymPath.SPATH [S.strSymbol "Core", S.varSymbol id]
+   let val sp = SymPath.SPATH [CoreSym.coreSym, S.varSymbol id]
        val err = fn _ => fn _ => fn _ => raise NoCore
     in Lookup.lookVal(env, sp, err)
    end
  fun CON' ((_, DA.REF, lt), ts, e) = APP (PRIM (PO.MAKEREF, lt, ts), e)
    | CON' ((_, DA.SUSP (SOME(DA.LVAR d, _)), lt), ts, e) =
-      if !Control.Lazy.earlyDT
+       let val v   = mkv ()
-      then bug "DA.SUSP in Translate.CON' while earlyDT is true."
-      else let val v   = mkv ()
                val fe = FN (v, LT.ltc_tuple [], e)
             in APP(TAPP (VAR d, ts), fe)
            end
-Line 161
+Line 159
  fun complain s = error (!region) s
  fun repErr x = complain EM.COMPLAIN x EM.nullErrorBody
+ fun repPolyEq () =
+     if !Control.polyEqWarn then complain EM.WARN "calling polyEqual" EM.nullErrorBody
+     else ()
  end (* markexn-local *)
-Line 239
+Line 240
  val persmap = ref (Map.empty : pidInfo Map.map)
  fun mkPid (pid, t, l, nameOp) =
-   (let val pinfo = Map.lookup (!persmap) pid
+     case Map.find (!persmap, pid)
-        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 =>
           let val (pinfo, var) = mkPidInfo (t, l, nameOp)
-           in persmap := Map.add(!persmap, pid, pinfo); var
+            in persmap := Map.insert(!persmap, pid, pinfo);
-          end)
+               var
+           end
+        | SOME pinfo =>
+           let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)
+               fun rmv (key, map) =
+                   let val (newMap, _) = Map.remove(map, key)
+                   in newMap
+                   end handle e => map
+            in persmap := Map.insert(rmv(pid, !persmap), pid, npinfo);
+               var
+           end
  (** converting an access w. type into a lambda expression *)
  fun mkAccT (p, t, nameOp) =
-Line 273
+Line 282
   * the primitive environment. (ZHONG)
   *)
  fun coreExn id =
-   ((case coreLookup(id, coreEnv)
+   ((case coreLookup(id, env)
       of V.CON(TP.DATACON{name, rep as DA.EXN _, typ, ...}) =>
            let val nt = toDconLty DI.top typ
                val nrep = mkRep(rep, nt, name)
-Line 283
+Line 292
     handle NoCore => (say "WARNING: no Core access \n"; INT 0))
  and coreAcc id =
-   ((case coreLookup(id, coreEnv)
+   ((case coreLookup(id, env)
       of V.VAL(V.VALvar{access, typ, path, ...}) =>
             mkAccT(access, toLty DI.top (!typ), getNameOp path)
        | _ => bug "coreAcc in translate")
-Line 349
+Line 358
              end
          | fill (VECTORpat(pats,ty)) = VECTORpat(map fill pats, ty)
          | fill (ORpat(p1, p2)) = ORpat(fill p1, fill p2)
-         | fill (CONpat(TP.DATACON{name, const, typ, rep, sign}, ts)) =
+         | fill (CONpat(TP.DATACON{name, const, typ, rep, sign, lazyp}, ts)) =
-             CONpat(TP.DATACON{name=name, const=const, typ=typ,
+             CONpat(TP.DATACON{name=name, const=const, typ=typ, lazyp=lazyp,
                          sign=sign, rep=mkRep(rep, toDconLty d typ, name)}, ts)
-         | fill (APPpat(TP.DATACON{name, const, typ, rep, sign}, ts, pat)) =
+         | fill (APPpat(TP.DATACON{name, const, typ, rep, sign, lazyp}, ts, pat)) =
-             APPpat(TP.DATACON{name=name, const=const, typ=typ, sign=sign,
+             APPpat(TP.DATACON{name=name, const=const, typ=typ, sign=sign, lazyp=lazyp,
                         rep=mkRep(rep, toDconLty d typ, name)}, ts, fill pat)
          | fill xp = xp
-Line 373
+Line 382
                        end))
        fun getPolyEq () =
-         (case (!polyEqRef)
+         (repPolyEq();
+          case (!polyEqRef)
            of SOME e => e
             | NONE => (let val e = coreAcc "polyequal"
                         in polyEqRef := (SOME e); e
-Line 686
+Line 696
                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))
                end
+ (**** ASSIGN(r, x) <> UPDATE(r, 0, x) under new array reps (JHR;1998-10-30)
          | g (PO.ASSIGN) =
                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
                                      | _ => bug "unexpected ty for ASSIGN"
-Line 701
+Line 712
                 in FN(x, argt,
                     APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))
                end
+ ****)
          | g p = PRIM(p, lt, ts)
-Line 908
+Line 920
  and mkFctexp (fe, d) =
    let fun g (VARfct f) = mkFct(f, d)
-         | g (FCTfct{param as M.STR{access=DA.LVAR v, ...}, argtycs, def}) =
+         | g (FCTfct {param as M.STR { access, ... }, argtycs, def }) =
+           (case access of
+                DA.LVAR v =>
                let val knds = map tpsKnd argtycs
                    val nd = DI.next d
                    val body = mkStrexp (def, nd)
                    val hdr = buildHdr v
                    (* binding of all v's components *)
-                in TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))
+                in
+                    TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))
                end
+              | _ => bug "mkFctexp: unexpected access")
          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)
          | g (MARKfct (b, reg)) = withRegion reg g b
          | g _ = bug "unexpected functor expressions in mkFctexp"
-Line 924
+Line 940
    end
  and mkStrbs (sbs, d) =
-   let fun g (STRB{str=M.STR{access=DA.LVAR v, ...}, def, ...}, b) =
+   let fun g (STRB{str=M.STR { access, ... }, def, ... }, b) =
+           (case access of
+                DA.LVAR v =>
                 let val hdr = buildHdr v
                     (* binding of all v's components *)
-                 in LET(v, mkStrexp(def, d), hdr b)
+                in
+                    LET(v, mkStrexp(def, d), hdr b)
                 end
+              | _ => bug "mkStrbs: unexpected access")
          | g _ = bug "unexpected structure bindings in mkStrbs"
     in fold g sbs
    end
  and mkFctbs (fbs, d) =
-   let fun g (FCTB{fct=M.FCT{access=DA.LVAR v, ...}, def, ...}, b) =
+   let fun g (FCTB{fct=M.FCT { access, ... }, def, ... }, b) =
+           (case access of
+                DA.LVAR v =>
                 let val hdr = buildHdr v
-                 in LET(v, mkFctexp(def, d), hdr b)
+                in
+                    LET(v, mkFctexp(def, d), hdr b)
                 end
+              | _ => bug "mkFctbs: unexpected access")
          | g _ = bug "unexpected functor bindings in mkStrbs"
     in fold g fbs
    end
-Line 1153
+Line 1173
  val body = mkDec (rootdec, DI.top) exportLexp
  (** wrapping up the body with the imported variables *)
- val (plexp, imports) = wrapPidInfo (body, Map.members (!persmap))
+ val (plexp, imports) = wrapPidInfo (body, Map.listItemsi (!persmap))
  fun prGen (flag,printE) s e =
    if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else ()
- val _ = prGen(Control.CG.printFlint, PPLexp.printLexp) "Translate" plexp
+ val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp
  (** normalizing the plambda expression into FLINT *)
  val flint = FlintNM.norm plexp
-Line 1169
+Line 1189
  end (* structure Translate *)
- (*
-  * $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
 Legend:



Removed from v.102
 


changed lines


 
Added in v.592
-Removed from v.102
+Added in v.592

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