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

sml/branches/SMLNJ/src/compiler/FLINT/trans/translate.sml revision 24, Thu Mar 12 00:49:58 1998 UTC sml/trunk/src/compiler/FLINT/trans/translate.sml revision 733, Fri Nov 17 05:13:45 2000 UTC
# Line 5  Line 5 
5  sig  sig
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 * Lambda.lvar list * StaticEnv.staticEnv *    val transDec : Absyn.dec * Access.lvar list
9                   ElabUtil.compInfo                   * StaticEnv.staticEnv * CompBasic.compInfo
10                   -> {genLambda: Lambda.lexp option list -> Lambda.lexp,                   -> {flint: FLINT.prog,
11                       importPids: PersStamps.persstamp list}                       imports: (PersStamps.persstamp
12                                   * CompBasic.importTree) list}
13    
14  end (* signature TRANSLATE *)  end (* signature TRANSLATE *)
15    
# Line 20  Line 21 
21        structure DA = Access        structure DA = Access
22        structure DI = DebIndex        structure DI = DebIndex
23        structure EM = ErrorMsg        structure EM = ErrorMsg
24        structure EU = ElabUtil        structure CB = CompBasic
25        structure II = InlInfo        structure II = InlInfo
26        structure LT = PLambdaType        structure LT = PLambdaType
27        structure M  = Modules        structure M  = Modules
# Line 28  Line 29 
29        structure PO = PrimOp        structure PO = PrimOp
30        structure PP = PrettyPrint        structure PP = PrettyPrint
31        structure S  = Symbol        structure S  = Symbol
32          structure SP = SymPath
33        structure LN = LiteralToNum        structure LN = LiteralToNum
       structure TM = TransModules  
34        structure TT = TransTypes        structure TT = TransTypes
35        structure TP = Types        structure TP = Types
36        structure TU = TypesUtil        structure TU = TypesUtil
# Line 57  Line 58 
58  fun ident x = x  fun ident x = x
59  val unitLexp = RECORD []  val unitLexp = RECORD []
60    
61    fun getNameOp p = if SP.null p then NONE else SOME(SP.last p)
62    
63  type pid = PersStamps.persstamp  type pid = PersStamps.persstamp
64    
65  (** old-style fold for cases where it is partially applied *)  (** old-style fold for cases where it is partially applied *)
# Line 69  Line 72 
72   * with the mkv in "compInfo" ? (ZHONG)   * with the mkv in "compInfo" ? (ZHONG)
73   *)   *)
74  val mkv = LambdaVar.mkLvar  val mkv = LambdaVar.mkLvar
75    fun mkvN NONE = mkv()
76      | mkvN (SOME s) = LambdaVar.namedLvar s
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 *)
84    fun extern (DA.EXTERN _) = true
85      | extern (DA.PATH(a, _)) = extern a
86      | extern _ = false
87    
88    (** an exception raised if coreEnv is not available *)
89    exception NoCore
90    
91    (****************************************************************************
92     *                          MAIN FUNCTION                                   *
93     *                                                                          *
94     *  val transDec : Absyn.dec * Access.lvar list                             *
95     *                 * StaticEnv.staticEnv * CompBasic.compInfo               *
96     *                 -> {flint: FLINT.prog,                                   *
97     *                     imports: (PersStamps.persstamp                       *
98     *                               * CompBasic.importTree) list}              *
99     ****************************************************************************)
100    
101    fun transDec (rootdec, exportLvars, env,
102                  compInfo as {errorMatch,error,...}: CB.compInfo) =
103    let
104    
105    (** generate the set of ML-to-FLINT type translation functions *)
106    val {tpsKnd, tpsTyc, toTyc, toLty, strLty, fctLty} = TT.genTT()
107    fun toTcLt d = (toTyc d, toLty d)
108    
109  (** translating the typ field in DATACON into lty; constant datacons  (** translating the typ field in DATACON into lty; constant datacons
110      will take ltc_unit as the argument *)      will take ltc_unit as the argument *)
111  fun toDconLty d ty =  fun toDconLty d ty =
112    (case ty    (case ty
113      of TP.POLYty{sign, tyfun=TP.TYFUN{arity, body}} =>      of TP.POLYty{sign, tyfun=TP.TYFUN{arity, body}} =>
114           if BT.isArrowType body then TT.toLty d ty           if BT.isArrowType body then toLty d ty
115           else TT.toLty d (TP.POLYty{sign=sign,           else toLty d (TP.POLYty{sign=sign,
116                                 tyfun=TP.TYFUN{arity=arity,                                 tyfun=TP.TYFUN{arity=arity,
117                                                body=BT.-->(BT.unitTy, body)}})                                                body=BT.-->(BT.unitTy, body)}})
118       | _ => if BT.isArrowType ty then TT.toLty d ty       | _ => if BT.isArrowType ty then toLty d ty
119              else TT.toLty d (BT.-->(BT.unitTy, ty)))              else toLty d (BT.-->(BT.unitTy, ty)))
   
 (** an exception raised if coreEnv is not available *)  
 exception NoCore  
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
134    | CON' x = CON x    | CON' x = CON x
135    
 (****************************************************************************  
  *                          MAIN FUNCTION                                   *  
  *                                                                          *  
  *  val transDec: Absyn.dec * Lambda.lexp * StaticEnv.staticEnv             *  
  *                * ElabUtil.compInfo                                       *  
  *                -> {genLambda : Lambda.lexp option list -> Lambda.lexp,   *  
  *                    importPids : PersStamps.persstamp list}               *  
  *                                                                          *  
  ****************************************************************************)  
   
 fun transDec (rootdec, exportLvars, env,  
               compInfo as {coreEnv,errorMatch,error,...}: EU.compInfo) =  
 let  
   
136  (*  (*
137   * The following code implements the exception tracking and   * The following code implements the exception tracking and
138   * errormsg reporting.   * errormsg reporting.
# Line 128  Line 140 
140    
141  local val region = ref(0,0)  local val region = ref(0,0)
142        val markexn = PRIM(PO.MARKEXN,        val markexn = PRIM(PO.MARKEXN,
143                        LT.ltc_arw(LT.ltc_tuple [LT.ltc_exn, LT.ltc_string],                        LT.ltc_parrow(LT.ltc_tuple [LT.ltc_exn, LT.ltc_string],
144                                   LT.ltc_exn), [])                                   LT.ltc_exn), [])
145  in  in
146    
# Line 147  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    
168  (**************** a temporary fix for the exportFn bug ****************)  (***************************************************************************
169     *          SHARING AND LIFTING OF STRUCTURE IMPORTS AND ACCESSES          *
170     ***************************************************************************)
171    
172  exception HASHTABLE  exception HASHTABLE
173  type key = int  type key = int
174    
175  (** hashkey of accesspath + accesspath + encoding of typ params + resvar *)  (** hashkey of accesspath + accesspath + resvar *)
176  type info = (key * int list * tyc * lvar)  type info = (key * int list * lvar)
177  val hashtable : info list Intmap.intmap = Intmap.new(32,HASHTABLE)  val hashtable : info list IntHashTable.hash_table =
178        IntHashTable.mkTable(32,HASHTABLE)
179  fun hashkey l = foldr (fn (x,y) => ((x * 10 + y) mod 1019)) 0 l  fun hashkey l = foldr (fn (x,y) => ((x * 10 + y) mod 1019)) 0 l
180    
181  fun toHt NONE = LT.tcc_void  fun buildHdr v =
182    | toHt (SOME(ts)) = LT.tcc_tuple ts    let val info = IntHashTable.lookup hashtable v
183          fun h((_, l, w), hdr) =
 fun fromHt x = if LT.tc_eqv(x, LT.tcc_void) then NONE else SOME(LT.tcd_tuple x)  
   
 fun buildHdr(v) =  
   let val info = Intmap.map hashtable v  
       fun h((_, l, tsEnc, w), hdr) =  
184               let val le = foldl (fn (k,e) => SELECT(k,e)) (VAR v) l               let val le = foldl (fn (k,e) => SELECT(k,e)) (VAR v) l
185                   val be = case (fromHt tsEnc)                in fn e => hdr(LET(w, le, e))
                            of NONE => le  
                             | SOME ts => TAPP(le, ts)  
               in fn e => hdr(LET(w, be, e))  
186               end               end
187     in foldr h ident info     in foldr h ident info
188    end handle _ => ident    end handle _ => ident
189    
190  fun lookbind(v, l, tsOp) =  fun bindvar (v, [], _) =  v
191    let val info = (Intmap.map hashtable v) handle _ => []    | bindvar (v, l, nameOp) =
192          let val info = (IntHashTable.lookup hashtable v) handle _ => []
193        val key = hashkey l        val key = hashkey l
194        val tsEnc = toHt tsOp            fun h [] =
195                    let val u = mkvN nameOp
196        fun h [] = (let val u = mkv()                   in IntHashTable.insert hashtable (v,(key,l,u)::info); u
197                     in Intmap.add hashtable (v,(key,l,tsEnc,u)::info); u                  end
198                    end)              | h((k',l',w)::r) =
199          | h((k',l', t', w)::r) =                  if (k' = key) then (if (l'=l) then w else h r) else h r
              if ((k' = key) andalso LT.tc_eqv(t', tsEnc))  
              then (if (l'=l) then w else h r) else h r  
200     in h info     in h info
201    end    end
202    
203  fun bindvar(v, [], NONE) = v  datatype pidInfo = ANON of (int * pidInfo) list
204    | bindvar(v, l, tsOp) = lookbind(v, l, tsOp)                   | NAMED of lvar * lty * (int * pidInfo) list
205    
206    fun mkPidInfo (t, l, nameOp) =
207      let val v = mkvN nameOp
208          fun h [] = NAMED(v, t, [])
209            | h (a::r) = ANON [(a, h r)]
210       in (h l, v)
211      end
212    
213    fun mergePidInfo (pi, t, l, nameOp) =
214      let fun h (z as NAMED(v,_,_), []) = (z, v)
215            | h (ANON xl, [])  =
216                  let val v = mkvN nameOp
217                   in (NAMED(v, t, xl), v)
218                  end
219            | h (z, a::r) =
220                  let val (xl, mknode) =
221                        case z of ANON c => (c, ANON)
222                                | NAMED (v,tt,c) => (c, fn x => NAMED(v,tt,x))
223    
224                      fun dump ((np, v), z, y) =
225                            let val nz = (a, np)::z
226                             in (mknode((rev y) @ nz), v)
227                            end
228    
229                      fun look ([], y) = dump(mkPidInfo(t, r, nameOp), [], y)
230                        | look (u as ((x as (i,pi))::z), y) =
231                            if i < a then look(z, x::y)
232                            else if i = a then dump(h(pi, r), z, y)
233                                 else dump(mkPidInfo(t, r, nameOp), u, y)
234    
235                   in look(xl, [])
236                  end
237       in h(pi, l)
238      end (* end of mergePidInfo *)
239    
240  (** a map that stores information about external references *)  (** a map that stores information about external references *)
241  val persmap = ref (Map.empty : (lvar * LT.lty) Map.map)  val persmap = ref (Map.empty : pidInfo Map.map)
242    
243  fun mkPid (pid, t, l) =  fun mkPid (pid, t, l, nameOp) =
244    (let val (var, t0) = Map.lookup (!persmap) pid      case Map.find (!persmap, pid)
245      in (persmap := Map.add(Map.delete(pid, !persmap),        of NONE =>
246                             pid, (var, LT.lt_merge(t0, t))));            let val (pinfo, var) = mkPidInfo (t, l, nameOp)
247         bindvar(var, l, (* tsOp *) NONE)             in persmap := Map.insert(!persmap, pid, pinfo);
248     end handle Map.MapF =>                var
249           let val nv = mkv()            end
250            in (persmap := Map.add(!persmap, pid, (nv, t));         | SOME pinfo =>
251                bindvar(nv, l, (* tsOp *) NONE))            let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)
252           end)                fun rmv (key, map) =
253                      let val (newMap, _) = Map.remove(map, key)
254                      in newMap
255                      end handle e => map
256               in persmap := Map.insert(rmv(pid, !persmap), pid, npinfo);
257                  var
258              end
259    
260  (** converting an access w. type into a lambda expression *)  (** converting an access w. type into a lambda expression *)
261  fun mkAccT (p, t) =  fun mkAccT (p, t, nameOp) =
262    let fun h(DA.LVAR v, l) = bindvar(v, l, NONE)    let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
263          | h(DA.EXTERN pid, l) =          | h(DA.EXTERN pid, l) = mkPid(pid, t, l, nameOp)
              (let val nt = foldr (fn (k,b) => LT.ltc_pst[(k,b)]) t l  
                in mkPid(pid, nt, l)  
               end)  
264          | h(DA.PATH(a,i), l) = h(a, i::l)          | h(DA.PATH(a,i), l) = h(a, i::l)
265          | h _ = bug "unexpected access in mkAccT"          | h _ = bug "unexpected access in mkAccT"
266     in VAR (h(p, []))     in VAR (h(p, []))
267    end (* new def for mkAccT *)    end (* new def for mkAccT *)
268    
269  (** converting an access into a lambda expression *)  (** converting an access into a lambda expression *)
270  fun mkAcc p =  fun mkAcc (p, nameOp) =
271    let fun h(DA.LVAR v, l) = bindvar(v, l, NONE)    let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
272          | h(DA.PATH(a,i), l) = h(a, i::l)          | h(DA.PATH(a,i), l) = h(a, i::l)
273          | h _ = bug "unexpected access in mkAcc"          | h _ = bug "unexpected access in mkAcc"
274     in VAR (h(p, []))     in VAR (h(p, []))
# Line 236  Line 283 
283   * the primitive environment. (ZHONG)   * the primitive environment. (ZHONG)
284   *)   *)
285  fun coreExn id =  fun coreExn id =
286    ((case coreLookup(id, coreEnv)    ((case coreLookup(id, env)
287       of V.CON(TP.DATACON{name, rep as DA.EXN _, typ, ...}) =>       of V.CON(TP.DATACON{name, rep as DA.EXN _, typ, ...}) =>
288            let val nt = toDconLty DI.top typ            let val nt = toDconLty DI.top typ
289                val nrep = mkRep(rep, nt)                val nrep = mkRep(rep, nt, name)
290             in CON'((name, nrep, nt), [], unitLexp)             in CON'((name, nrep, nt), [], unitLexp)
291            end            end
292        | _ => bug "coreExn in translate")        | _ => bug "coreExn in translate")
293     handle NoCore => (say "WARNING: no Core access \n"; INT 0))     handle NoCore => (say "WARNING: no Core access \n"; INT 0))
294    
295  and coreAcc id =  and coreAcc id =
296    ((case coreLookup(id, coreEnv)    ((case coreLookup(id, env)
297       of V.VAL(V.VALvar{access, typ, ...}) =>       of V.VAL(V.VALvar{access, typ, path, ...}) =>
298             mkAccT(access, TT.toLty DI.top (!typ))             mkAccT(access, toLty DI.top (!typ), getNameOp path)
299        | _ => bug "coreAcc in translate")        | _ => bug "coreAcc in translate")
300     handle NoCore => (say "WARNING: no Core access \n"; INT 0))     handle NoCore => (say "WARNING: no Core access \n"; INT 0))
301    
302    
303  (** expands the flex record pattern and convert the EXN access pat *)  (** expands the flex record pattern and convert the EXN access pat *)
304  (** internalize the conrep's access, always exceptions *)  (** internalize the conrep's access, always exceptions *)
305  and mkRep (rep, lt) =  and mkRep (rep, lt, name) =
306    let fun g (DA.LVAR v, l, t)  = bindvar(v, l, NONE)    let fun g (DA.LVAR v, l, t)  = bindvar(v, l, SOME name)
307          | g (DA.PATH(a, i), l, t) = g(a, i::l, LT.ltc_pst [(i, t)])          | g (DA.PATH(a, i), l, t) = g(a, i::l, t)
308          | g (DA.EXTERN p, l, t) = mkPid(p, t, l)          | g (DA.EXTERN p, l, t) = mkPid(p, t, l, SOME name)
309          | g _ = bug "unexpected access in mkRep"          | g _ = bug "unexpected access in mkRep"
310    
311     in case rep     in case rep
# Line 274  Line 321 
321          | _ => rep          | _ => rep
322    end    end
323    
 (** converting a non-value-carrying exn into a lambda expression *)  
 fun mkExnAcc acc = mkAccT (acc, LT.ltc_exn)  
   
324  (** converting a value of access+info into the lambda expression *)  (** converting a value of access+info into the lambda expression *)
325  fun mkAccInfo (acc, info, getLty) =  fun mkAccInfo (acc, info, getLty, nameOp) =
326    let fun extern (DA.EXTERN _) = true    if extern acc then mkAccT(acc, getLty(), nameOp) else mkAcc (acc, nameOp)
         | extern (DA.PATH(a, _)) = extern a  
         | extern _ = false  
   
    in if extern acc then mkAccT(acc, getLty()) else mkAcc acc  
   end  
327    
328  fun fillPat(pat, d) =  fun fillPat(pat, d) =
329    let fun fill (CONSTRAINTpat (p,t)) = fill p    let fun fill (CONSTRAINTpat (p,t)) = fill p
# Line 320  Line 359 
359              end              end
360          | fill (VECTORpat(pats,ty)) = VECTORpat(map fill pats, ty)          | fill (VECTORpat(pats,ty)) = VECTORpat(map fill pats, ty)
361          | fill (ORpat(p1, p2)) = ORpat(fill p1, fill p2)          | fill (ORpat(p1, p2)) = ORpat(fill p1, fill p2)
362          | fill (CONpat(TP.DATACON{name, const, typ, rep, sign}, ts)) =          | fill (CONpat(TP.DATACON{name, const, typ, rep, sign, lazyp}, ts)) =
363              CONpat(TP.DATACON{name=name, const=const, typ=typ,              CONpat(TP.DATACON{name=name, const=const, typ=typ, lazyp=lazyp,
364                          sign=sign, rep=mkRep(rep, toDconLty d typ)}, ts)                          sign=sign, rep=mkRep(rep, toDconLty d typ, name)}, ts)
365          | fill (APPpat(TP.DATACON{name, const, typ, rep, sign}, ts, pat)) =          | fill (APPpat(TP.DATACON{name, const, typ, rep, sign, lazyp}, ts, pat)) =
366              APPpat(TP.DATACON{name=name, const=const, typ=typ, sign=sign,              APPpat(TP.DATACON{name=name, const=const, typ=typ, sign=sign, lazyp=lazyp,
367                         rep=mkRep(rep, toDconLty d typ)}, ts, fill pat)                         rep=mkRep(rep, toDconLty d typ, name)}, ts, fill pat)
368          | fill xp = xp          | fill xp = xp
369    
370     in fill pat     in fill pat
371    end (* function fillPat *)    end (* function fillPat *)
372    
 (*  
 val fillPat = Stats.doPhase(Stats.makePhase "Compiler 047 4-fillPat") fillPat  
 *)  
   
373  (** The runtime polymorphic equality and string equality dictionary. *)  (** The runtime polymorphic equality and string equality dictionary. *)
374  val eqDict =  val eqDict =
375    let val strEqRef : lexp option ref = ref NONE    let val strEqRef : lexp option ref = ref NONE
# Line 348  Line 383 
383                        end))                        end))
384    
385        fun getPolyEq () =        fun getPolyEq () =
386          (case (!polyEqRef)          (repPolyEq();
387             case (!polyEqRef)
388            of SOME e => e            of SOME e => e
389             | NONE => (let val e = coreAcc "polyequal"             | NONE => (let val e = coreAcc "polyequal"
390                         in polyEqRef := (SOME e); e                         in polyEqRef := (SOME e); e
# Line 636  Line 672 
672                            COND(APP(cmpOp(LESSU),                            COND(APP(cmpOp(LESSU),
673                                     RECORD[vi,APP(lenOp seqtc, va)]),                                     RECORD[vi,APP(lenOp seqtc, va)]),
674                                 APP(oper, RECORD[va,vi,vv]),                                 APP(oper, RECORD[va,vi,vv]),
675                                 mkRaise(coreExn "Subscript", lt_int))))))                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))
676                end                end
677    
678          | g (PO.NUMUPDATE{kind,checked=true}) =          | g (PO.NUMUPDATE{kind,checked=true}) =
# Line 658  Line 694 
694                            COND(APP(cmpOp(LESSU),                            COND(APP(cmpOp(LESSU),
695                                     RECORD[vi,APP(lenOp tc1, va)]),                                     RECORD[vi,APP(lenOp tc1, va)]),
696                                 APP(oper', RECORD[va,vi,vv]),                                 APP(oper', RECORD[va,vi,vv]),
697                                 mkRaise(coreExn "Subscript", lt_int))))))                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))
698                end                end
699    
700    (**** ASSIGN(r, x) <> UPDATE(r, 0, x) under new array reps (JHR;1998-10-30)
701          | g (PO.ASSIGN) =          | g (PO.ASSIGN) =
702                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
703                                      | _ => bug "unexpected ty for ASSIGN"                                      | _ => bug "unexpected ty for ASSIGN"
# Line 676  Line 713 
713                 in FN(x, argt,                 in FN(x, argt,
714                     APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))                     APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))
715                end                end
716    ****)
717    
718          | g p = PRIM(p, lt, ts)          | g p = PRIM(p, lt, ts)
719    
# Line 694  Line 732 
732   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *
733   *                                                                         *   *                                                                         *
734   ***************************************************************************)   ***************************************************************************)
735  fun mkVar (v as V.VALvar{access, info, typ, ...}, d) =  fun mkVar (v as V.VALvar{access, info, typ, path}, d) =
736        mkAccInfo(access, info, fn () => TT.toLty d (!typ))        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)
737    | mkVar _ = bug "unexpected vars in mkVar"    | mkVar _ = bug "unexpected vars in mkVar"
738    
739  fun mkVE (v as V.VALvar {info=II.INL_PRIM(p, SOME typ), ...}, ts, d) =  fun mkVE (v as V.VALvar {info=II.INL_PRIM(p, SOME typ), ...}, ts, d) =
740        (case (p, ts)        (case (p, ts)
741          of (PO.POLYEQL, [t]) => eqGen(typ, t, d)          of (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)
742           | (PO.POLYNEQ, [t]) => composeNOT(eqGen(typ, t, d), TT.toLty d t)           | (PO.POLYNEQ, [t]) => composeNOT(eqGen(typ, t, toTcLt d), toLty d t)
743           | (PO.INLMKARRAY, [t]) =>           | (PO.INLMKARRAY, [t]) =>
744                  let val dict =                  let val dict =
745                        {default = coreAcc "mkNormArray",                        {default = coreAcc "mkNormArray",
746                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}
747                   in GENOP (dict, p, TT.toLty d typ, map (TT.toTyc d) ts)                   in GENOP (dict, p, toLty d typ, map (toTyc d) ts)
748                  end                  end
749           | _ => transPrim(p, (TT.toLty d typ), map (TT.toTyc d) ts))           | _ => transPrim(p, (toLty d typ), map (toTyc d) ts))
750    
751    | mkVE (v as V.VALvar {info=II.INL_PRIM(p, NONE), typ, ...}, ts, d) =    | mkVE (v as V.VALvar {info=II.INL_PRIM(p, NONE), typ, ...}, ts, d) =
752        (case ts of [] => transPrim(p, (TT.toLty d (!typ)), [])        (case ts of [] => transPrim(p, (toLty d (!typ)), [])
753                  | [x] =>                  | [x] =>
754                     (* a temporary hack to resolve the boot/built-in.sml file *)                     (* a temporary hack to resolve the boot/built-in.sml file *)
755                     (let val lt = TT.toLty d (!typ)                     (let val lt = toLty d (!typ)
756                          val nt = TT.toLty d x                          val nt = toLty d x
757                       in if LT.lt_eqv(LT.ltc_top, lt)                       in if LT.lt_eqv(LT.ltc_top, lt)
758                          then transPrim(p, nt, [])                          then transPrim(p, nt, [])
759                          else bug "unexpected primop in mkVE"                          else bug "unexpected primop in mkVE"
# Line 723  Line 761 
761                  | _ => bug "unexpected poly primops in mkVE")                  | _ => bug "unexpected poly primops in mkVE")
762    
763    | mkVE (v, [], d) = mkVar(v, d)    | mkVE (v, [], d) = mkVar(v, d)
764    | mkVE (v, ts, d) = TAPP(mkVar(v, d), map (TT.toTyc d) ts)    | mkVE (v, ts, d) = TAPP(mkVar(v, d), map (toTyc d) ts)
765    
766  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
767    let val lt = toDconLty d typ    let val lt = toDconLty d typ
768        val rep' = mkRep(rep, lt)        val rep' = mkRep(rep, lt, name)
769        val dc = (name, rep', lt)        val dc = (name, rep', lt)
770        val ts' = map (TT.toTyc d) ts        val ts' = map (toTyc d) ts
771     in if const then CON'(dc, ts', unitLexp)     in if const then CON'(dc, ts', unitLexp)
772        else (case apOp        else (case apOp
773               of SOME le => CON'(dc, ts', le)               of SOME le => CON'(dc, ts', le)
# Line 741  Line 779 
779    end    end
780    
781  fun mkStr (s as M.STR{access, info, ...}, d) =  fun mkStr (s as M.STR{access, info, ...}, d) =
782        mkAccInfo(access, info, fn () => TM.strLty(s, d, compInfo))      mkAccInfo(access, info, fn () => strLty(s, d, compInfo), NONE)
783    | mkStr _ = bug "unexpected structures in mkStr"    | mkStr _ = bug "unexpected structures in mkStr"
784    
785  fun mkFct (f as M.FCT{access, info, ...}, d) =  fun mkFct (f as M.FCT{access, info, ...}, d) =
786        mkAccInfo(access, info, fn () => TM.fctLty(f, d, compInfo))      mkAccInfo(access, info, fn () => fctLty(f, d, compInfo), NONE)
787    | mkFct _ = bug "unexpected functors in mkFct"    | mkFct _ = bug "unexpected functors in mkFct"
788    
789  fun mkBnd d =  fun mkBnd d =
790    let fun g (B.VALbind v) = mkVar(v, d)    let fun g (B.VALbind v) = mkVar(v, d)
791          | g (B.STRbind s) = mkStr(s, d)          | g (B.STRbind s) = mkStr(s, d)
792          | g (B.FCTbind f) = mkFct(f, d)          | g (B.FCTbind f) = mkFct(f, d)
793          | g (B.CONbind (TP.DATACON{rep=(DA.EXN acc), typ, ...})) =          | g (B.CONbind (TP.DATACON{rep=(DA.EXN acc), name, typ, ...})) =
794                let val nt = toDconLty d typ                let val nt = toDconLty d typ
795                    val (argt,_) = LT.ltd_parrow nt                    val (argt,_) = LT.ltd_parrow nt
796                 in mkAccT (acc, LT.ltc_etag argt)            in mkAccT (acc, LT.ltc_etag argt, SOME name)
797                end                end
798          | g _ = bug "unexpected bindings in mkBnd"          | g _ = bug "unexpected bindings in mkBnd"
799     in g     in g
# Line 817  Line 855 
855                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]
856                    val rootv = mkv()                    val rootv = mkv()
857                    fun finish x = LET(rootv, ee, x)                    fun finish x = LET(rootv, ee, x)
858                 in MC.bindCompile(env, rules, finish, rootv, d, complain)                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain)
859                end                end
860     in fold g vbs     in fold g vbs
861    end    end
# Line 827  Line 865 
865                   exp, boundtvs=tvs, ...}, (vlist, tlist, elist)) =                   exp, boundtvs=tvs, ...}, (vlist, tlist, elist)) =
866                 let val ee = mkExp(exp, d) (* was mkPE(exp, d, tvs) *)                 let val ee = mkExp(exp, d) (* was mkPE(exp, d, tvs) *)
867                         (* we no longer track type bindings at RVB anymore ! *)                         (* we no longer track type bindings at RVB anymore ! *)
868                     val vt = TT.toLty d ty                     val vt = toLty d ty
869                  in (v::vlist, vt::tlist, ee::elist)                  in (v::vlist, vt::tlist, ee::elist)
870                 end                 end
871          | g _ = bug "unexpected valrec bindings in mkRVBs"          | g _ = bug "unexpected valrec bindings in mkRVBs"
# Line 844  Line 882 
882                    val (argt, _) = LT.ltd_parrow nt                    val (argt, _) = LT.ltd_parrow nt
883                 in LET(v, ETAG(mkExp(ident, d), argt), b)                 in LET(v, ETAG(mkExp(ident, d), argt), b)
884                end                end
885          | g (EBdef {exn=TP.DATACON{rep=DA.EXN(DA.LVAR v), typ, ...},          | g (EBdef {exn=TP.DATACON{rep=DA.EXN(DA.LVAR v), typ, name, ...},
886                      edef=TP.DATACON{rep=DA.EXN(acc), ...}}, b) =                      edef=TP.DATACON{rep=DA.EXN(acc), ...}}, b) =
887                let val nt = toDconLty d typ                let val nt = toDconLty d typ
888                    val (argt, _) = LT.ltd_parrow nt                    val (argt, _) = LT.ltd_parrow nt
889                 in LET(v, mkAccT(acc, LT.ltc_etag argt), b)                 in LET(v, mkAccT(acc, LT.ltc_etag argt, SOME name), b)
890                end                end
891          | g _ = bug "unexpected exn bindings in mkEBs"          | g _ = bug "unexpected exn bindings in mkEBs"
892    
# Line 871  Line 909 
909          | g (STRstr bs) = SRECORD (map (mkBnd d) bs)          | g (STRstr bs) = SRECORD (map (mkBnd d) bs)
910          | g (APPstr {oper, arg, argtycs}) =          | g (APPstr {oper, arg, argtycs}) =
911                let val e1 = mkFct(oper, d)                let val e1 = mkFct(oper, d)
912                    val tycs = map (TT.tpsTyc d) argtycs                    val tycs = map (tpsTyc d) argtycs
913                    val e2 = mkStr(arg, d)                    val e2 = mkStr(arg, d)
914                 in APP(TAPP(e1, tycs), e2)                 in APP(TAPP(e1, tycs), e2)
915                end                end
# Line 883  Line 921 
921    
922  and mkFctexp (fe, d) =  and mkFctexp (fe, d) =
923    let fun g (VARfct f) = mkFct(f, d)    let fun g (VARfct f) = mkFct(f, d)
924          | g (FCTfct{param as M.STR{access=DA.LVAR v, ...}, argtycs, def}) =          | g (FCTfct {param as M.STR { access, ... }, argtycs, def }) =
925                let val knds = map TT.tpsKnd argtycs            (case access of
926                   DA.LVAR v =>
927                   let val knds = map tpsKnd argtycs
928                    val nd = DI.next d                    val nd = DI.next d
929                    val body = mkStrexp (def, nd)                    val body = mkStrexp (def, nd)
930                    val hdr = buildHdr v                    val hdr = buildHdr v
931                    (* binding of all v's components *)                    (* binding of all v's components *)
932                 in TFN(knds, FN(v, TM.strLty(param, nd, compInfo), hdr body))                 in
933                       TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))
934                end                end
935                 | _ => bug "mkFctexp: unexpected access")
936          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)
937          | g (MARKfct (b, reg)) = withRegion reg g b          | g (MARKfct (b, reg)) = withRegion reg g b
938          | g _ = bug "unexpected functor expressions in mkFctexp"          | g _ = bug "unexpected functor expressions in mkFctexp"
# Line 899  Line 941 
941    end    end
942    
943  and mkStrbs (sbs, d) =  and mkStrbs (sbs, d) =
944    let fun g (STRB{str=M.STR{access=DA.LVAR v, ...}, def, ...}, b) =    let fun g (STRB{str=M.STR { access, ... }, def, ... }, b) =
945              (case access of
946                   DA.LVAR v =>
947                 let val hdr = buildHdr v                 let val hdr = buildHdr v
948                     (* binding of all v's components *)                     (* binding of all v's components *)
949                  in LET(v, mkStrexp(def, d), hdr b)                 in
950                       LET(v, mkStrexp(def, d), hdr b)
951                 end                 end
952                 | _ => bug "mkStrbs: unexpected access")
953          | g _ = bug "unexpected structure bindings in mkStrbs"          | g _ = bug "unexpected structure bindings in mkStrbs"
   
954     in fold g sbs     in fold g sbs
955    end    end
956    
957  and mkFctbs (fbs, d) =  and mkFctbs (fbs, d) =
958    let fun g (FCTB{fct=M.FCT{access=DA.LVAR v, ...}, def, ...}, b) =    let fun g (FCTB{fct=M.FCT { access, ... }, def, ... }, b) =
959              (case access of
960                   DA.LVAR v =>
961                 let val hdr = buildHdr v                 let val hdr = buildHdr v
962                  in LET(v, mkFctexp(def, d), hdr b)                 in
963                       LET(v, mkFctexp(def, d), hdr b)
964                 end                 end
965                 | _ => bug "mkFctbs: unexpected access")
966          | g _ = bug "unexpected functor bindings in mkStrbs"          | g _ = bug "unexpected functor bindings in mkStrbs"
   
967     in fold g fbs     in fold g fbs
968    end    end
969    
# Line 929  Line 975 
975   *    val mkDec : A.dec * DI.depth -> L.lexp -> L.lexp                     *   *    val mkDec : A.dec * DI.depth -> L.lexp -> L.lexp                     *
976   *                                                                         *   *                                                                         *
977   ***************************************************************************)   ***************************************************************************)
 (*  
 and mkDec x = Stats.doPhase(Stats.makePhase "Compiler 048 mkDec") mkDec0 x  
 and mkExp x = Stats.doPhase(Stats.makePhase "Compiler 049 mkExp") mkExp0 x  
 *)  
978  and mkDec (dec, d) =  and mkDec (dec, d) =
979    let fun g (VALdec vbs) = mkVBs(vbs, d)    let fun g (VALdec vbs) = mkVBs(vbs, d)
980          | g (VALRECdec rvbs) = mkRVBs(rvbs, d)          | g (VALRECdec rvbs) = mkRVBs(rvbs, d)
# Line 947  Line 989 
989                let val f = withRegion reg g x                let val f = withRegion reg g x
990                 in fn y => withRegion reg f y                 in fn y => withRegion reg f y
991                end                end
992            | g (OPENdec xs) =
993                  let (* special hack to make the import tree simpler *)
994                      fun mkos (_, s as M.STR { access = acc, ... }) =
995                          if extern acc then
996                              let val _ = mkAccT(acc, strLty(s, d, compInfo), NONE)
997                              in ()
998                              end
999                          else ()
1000                        | mkos _ = ()
1001                   in app mkos xs; ident
1002                  end
1003          | g _ = ident          | g _ = ident
1004     in g dec     in g dec
1005    end    end
1006    
1007  and mkExp (exp, d) =  and mkExp (exp, d) =
1008    let val tTyc = TT.toTyc d    let val tTyc = toTyc d
1009        val tLty = TT.toLty d        val tLty = toLty d
1010    
1011        fun mkRules xs = map (fn (RULE(p, e)) => (fillPat(p, d), g e)) xs        fun mkRules xs = map (fn (RULE(p, e)) => (fillPat(p, d), g e)) xs
1012    
# Line 984  Line 1037 
1037               (** NOTE: the above won't work for cross compiling to               (** NOTE: the above won't work for cross compiling to
1038                         multi-byte characters **)                         multi-byte characters **)
1039    
1040          | g (RECORDexp []) = INT 0          | g (RECORDexp []) = unitLexp
1041          | g (RECORDexp xs) =          | g (RECORDexp xs) =
1042               if sorted xs then RECORD (map (fn (_,e) => g e) xs)               if sorted xs then RECORD (map (fn (_,e) => g e) xs)
1043               else let val vars = map (fn (l,e) => (l,(g e, mkv()))) xs               else let val vars = map (fn (l,e) => (l,(g e, mkv()))) xs
# Line 1008  Line 1061 
1061          | g (PACKexp(e, ty, tycs)) = g e          | g (PACKexp(e, ty, tycs)) = g e
1062  (*  (*
1063               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)
1064                   val ts = map (TT.tpsTyc d) tps                   val ts = map (tpsTyc d) tps
1065                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)
1066                   val nts = ListPair.map LtyEnv.tcAbs (ts, ks)                   val nts = ListPair.map LtyEnv.tcAbs (ts, ks)
1067                   val nd = DI.next d                   val nd = DI.next d
1068                in case (ks, tps)                in case (ks, tps)
1069                    of ([], []) => g e                    of ([], []) => g e
1070                     | _ => PACK(LT.ltc_poly(ks, [TT.toLty nd nty]), ts, nts , g e)                     | _ => PACK(LT.ltc_poly(ks, [toLty nd nty]),
1071                                   ts, nts , g e)
1072               end               end
1073  *)  *)
1074          | g (SEQexp [e]) = g e          | g (SEQexp [e]) = g e
# Line 1029  Line 1083 
1083               let val rootv = mkv()               let val rootv = mkv()
1084                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1085                   val l' = mkRules l                   val l' = mkRules l
1086                in HANDLE(g e, MC.handCompile(env, l', f, rootv, d, complain))                in HANDLE(g e, MC.handCompile(env, l', f,
1087                                                rootv, toTcLt d, complain))
1088               end               end
1089    
1090          | g (FNexp (l, ty)) =          | g (FNexp (l, ty)) =
1091               let val rootv = mkv()               let val rootv = mkv()
1092                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1093                in MC.matchCompile (env, mkRules l, f, rootv, d, complain)                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d, complain)
1094               end               end
1095    
1096          | g (CASEexp (ee, l, isMatch)) =          | g (CASEexp (ee, l, isMatch)) =
# Line 1044  Line 1099 
1099                   fun f x = LET(rootv, ee', x)                   fun f x = LET(rootv, ee', x)
1100                   val l' = mkRules l                   val l' = mkRules l
1101                in if isMatch                in if isMatch
1102                   then MC.matchCompile (env, l', f, rootv, d, complain)                   then MC.matchCompile (env, l', f, rootv, toTcLt d, complain)
1103                   else MC.bindCompile (env, l', f, rootv, d, complain)                   else MC.bindCompile (env, l', f, rootv, toTcLt d, complain)
1104               end               end
1105    
1106          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)
# Line 1059  Line 1114 
1114    end    end
1115    
1116    
1117    (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)
1118    fun wrapPidInfo (body, pidinfos) =
1119      let val imports =
1120            let fun p2itree (ANON xl) =
1121                      CB.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)
1122                  | p2itree (NAMED _) = CB.ITNODE []
1123             in map (fn (p, pi) => (p, p2itree pi)) pidinfos
1124            end
1125  (*  (*
1126   * closeLexp `closes' over all free (EXTERN) variables [`inlining' version]        val _ = let val _ = say "\n ****************** \n"
1127   *  - make sure that all operations on various imparative data structures                    val _ = say "\n the current import tree is :\n"
1128   *    are carried out NOW and not later when the result function is called.                    fun tree (CB.ITNODE []) = ["\n"]
1129   *                      | tree (CB.ITNODE xl) =
1130   * val closeLexp : PLambda.lexp                          foldr (fn ((i, x), z) =>
1131   *                  -> (Lambda.lexp option list -> Lambda.lexp) * pid list                            let val ts = tree x
1132                                  val u = (Int.toString i)  ^ "   "
1133                               in (map (fn y => (u ^ y)) ts) @ z
1134                              end) [] xl
1135                      fun pp (p, n) =
1136                        (say ("Pid " ^ (PersStamps.toHex p) ^ "\n");
1137                         app say (tree n))
1138                   in app pp imports; say "\n ****************** \n"
1139                  end
1140   *)   *)
1141  fun closeLexp body =        val plexp =
1142    let (* free variable + pid + inferred lty *)          let fun get ((_, ANON xl), z) = foldl get z xl
1143        val l: (pid * (lvar * LT.lty)) list = Map.members (!persmap)                | get ((_, u as NAMED (_,t,_)), (n,cs,ts)) =
1144                      (n+1, (n,u)::cs, t::ts)
1145        (* the name of the `main' argument *)  
1146        val imports = mkv ()              (* get the fringe information *)
1147        val impVar = VAR (imports)              val getp = fn ((_, pi), z) => get((0, pi), z)
1148                val (finfos, lts) =
1149        val impLty = LT.ltc_str (map (fn (_, (_, lt)) => lt) l)                let val (_, fx, lx) = foldl getp (0,[],[]) pidinfos
1150                   in (rev fx, rev lx)
1151        fun h (_ :: xs, (_, (lvar, lt)) :: rest, i, lexp) =                end
1152              let val hdr = buildHdr lvar  
1153                  val bindexp = LET(lvar, SELECT(i, impVar), hdr lexp)              (* do the selection of all import variables *)
1154               in h (xs, rest, i + 1, bindexp)              fun mksel (u, xl, be) =
1155              end                let fun g ((i, pi), be) =
1156          | h ([], [], _, lexp) = FN (imports, impLty, lexp)                      let val (v, xs) = case pi of ANON z => (mkv(), z)
1157          | h _ = bug "unexpected arguments in close"                                                 | NAMED(v,_,z) => (v, z)
1158                         in LET(v, SELECT(i, u), mksel(VAR v, xs, be))
1159        fun genLexp inls =                      end
1160          let val plexp = h(inls, l, 0, body)                 in foldr g be xl
1161                  end
1162        val _ = if !Control.CG.printLambda              val impvar = mkv()
1163                then (say "\n\n[After Translation into PLambda ...]\n\n";              val implty = LT.ltc_str lts
1164                      PPLexp.printLexp plexp)              val nbody = mksel (VAR impvar, finfos, body)
1165                else ()           in FN(impvar, implty, nbody)
1166            end
1167       in (plexp, imports)
1168      end (* function wrapPidInfo *)
1169    
1170           in if !Control.CG.flinton then  (** the list of things being exported from the current compilation unit *)
1171                let val flexp = (FlintNM.norm plexp)  val exportLexp = SRECORD (map VAR exportLvars)
1172    
1173        val _ = if !Control.CG.printLambda  (** translating the ML absyn into the PLambda expression *)
1174                then (say "\n\n[After Translation into FLINT ...]\n\n";  val body = mkDec (rootdec, DI.top) exportLexp
                     PPFlint.printFundec flexp)  
               else ()  
1175    
1176                 in (Flint2Lambda.transFundec flexp)  (** wrapping up the body with the imported variables *)
1177                end  val (plexp, imports) = wrapPidInfo (body, Map.listItemsi (!persmap))
             else NormLexp.normLexp plexp  
         end  
1178    
1179     in {genLambda = (fn inls => genLexp inls),  fun prGen (flag,printE) s e =
1180         importPids = (map #1 l)}    if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else ()
1181    end  val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp
1182    
1183  val exportLexp = SRECORD (map VAR exportLvars)  (** normalizing the plambda expression into FLINT *)
1184    val flint = FlintNM.norm plexp
1185    
1186  in closeLexp (mkDec (rootdec, DI.top) exportLexp)  in {flint = flint, imports = imports}
1187  end (* function transDec *)  end (* function transDec *)
1188    
1189  end (* top-level local *)  end (* top-level local *)
1190  end (* structure Translate *)  end (* structure Translate *)
1191    
 (*  
  * $Log: translate.sml,v $  
  * Revision 1.9  1997/08/15  16:05:26  jhr  
  *   Bug fix to lift free structure references outside closures [zsh].  
  *  
  * Revision 1.8  1997/05/05  20:00:17  george  
  *   Change the term language into the quasi-A-normal form. Added a new round  
  *   of lambda contraction before and after type specialization and  
  *   representation analysis. Type specialization including minimum type  
  *   derivation is now turned on all the time. Real array is now implemented  
  *   as realArray. A more sophisticated partial boxing scheme is added and  
  *   used as the default.  
  *  
  * Revision 1.7  1997/04/18  15:49:04  george  
  *   Cosmetic changes on some constructor names. Changed the shape for  
  *   FIX type to potentially support shared dtsig. -- zsh  
  *  
  * Revision 1.6  1997/04/08  19:42:15  george  
  *   Fixed a bug in inlineShift operations. The test to determine if the  
  *   shift amount is within range should always an UINT 31 comparison --  
  *   regardless of the entity being shifted.  
  *  
  * Revision 1.5  1997/03/25  13:41:44  george  
  *   Fixing the coredump bug caused by duplicate top-level declarations.  
  *   For example, in almost any versions of SML/NJ, typing  
  *           val x = "" val x = 3  
  *   would lead to core dump. This is avoided by changing the "exportLexp"  
  *   field returned by the pickling function (pickle/picklemod.sml) into  
  *   a list of lambdavars, and then during the pretty-printing (print/ppdec.sml),  
  *   each variable declaration is checked to see if it is in the "exportLvars"  
  *   list, if true, it will be printed as usual, otherwise, the pretty-printer  
  *   will print the result as <hiddle-value>.  
  *                                              -- zsh  
  *  
  * Revision 1.4  1997/03/22  18:25:25  dbm  
  * Added temporary debugging code.  This could be cleaned out later.  
  *  
  * Revision 1.3  1997/02/26  21:54:48  george  
  *   Putting back the access-lifting code to avoid the "exportFn image blowup"  
  *   bug --- BUG 1142.  
  *  
  * Revision 1.1.1.1  1997/01/14  01:38:47  george  
  *   Version 109.24  
  *  
  *)  
1192    

Legend:
Removed from v.24  
changed lines
  Added in v.733

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