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 422, Sun Sep 5 22:49:38 1999 UTC revision 733, Fri Nov 17 05:13:45 2000 UTC
# 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
# Line 159  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 171  Line 174 
174    
175  (** hashkey of accesspath + accesspath + resvar *)  (** hashkey of accesspath + accesspath + resvar *)
176  type info = (key * int list * 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 buildHdr v =  fun buildHdr v =
182    let val info = Intmap.map hashtable v    let val info = IntHashTable.lookup hashtable v
183        fun h((_, l, w), hdr) =        fun h((_, l, 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                in fn e => hdr(LET(w, le, e))                in fn e => hdr(LET(w, le, e))
# Line 185  Line 189 
189    
190  fun bindvar (v, [], _) =  v  fun bindvar (v, [], _) =  v
191    | bindvar (v, l, nameOp) =    | bindvar (v, l, nameOp) =
192        let val info = (Intmap.map hashtable v) handle _ => []        let val info = (IntHashTable.lookup hashtable v) handle _ => []
193            val key = hashkey l            val key = hashkey l
194            fun h [] =            fun h [] =
195                  let val u = mkvN nameOp                  let val u = mkvN nameOp
196                   in Intmap.add hashtable (v,(key,l,u)::info); u                   in IntHashTable.insert hashtable (v,(key,l,u)::info); u
197                  end                  end
198              | h((k',l',w)::r) =              | h((k',l',w)::r) =
199                  if (k' = key) then (if (l'=l) then w else h r) else h r                  if (k' = key) then (if (l'=l) then w else h r) else h r
# Line 279  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, name)                val nrep = mkRep(rep, nt, name)
# Line 289  Line 293 
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, path, ...}) =>       of V.VAL(V.VALvar{access, typ, path, ...}) =>
298             mkAccT(access, toLty DI.top (!typ), getNameOp path)             mkAccT(access, toLty DI.top (!typ), getNameOp path)
299        | _ => bug "coreAcc in translate")        | _ => bug "coreAcc in translate")
# Line 379  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 916  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              (case access of
926                   DA.LVAR v =>
927                let val knds = map tpsKnd argtycs                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, 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 932  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    

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

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