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-3/compiler/FLINT/trans/transtypes.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-3/compiler/FLINT/trans/transtypes.sml

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

revision 3357, Sun May 17 13:59:39 2009 UTC revision 3358, Mon May 18 04:28:44 2009 UTC
# Line 14  Line 14 
14                 -> {tpsKnd : primary -> PLambdaType.tkind,                 -> {tpsKnd : primary -> PLambdaType.tkind,
15                     tpsTyc : primaryEnv -> DebIndex.depth -> primary                     tpsTyc : primaryEnv -> DebIndex.depth -> primary
16                              -> PLambdaType.tyc,                              -> PLambdaType.tyc,
17                     toTyc  : flexmap ->                     toTyc  : primaryEnv ->
18                              DebIndex.depth -> Types.ty -> PLambdaType.tyc,                              DebIndex.depth -> Types.ty -> PLambdaType.tyc,
19                     toLty  : flexmap -> DebIndex.depth -> Types.ty                     toLty  : primaryEnv -> DebIndex.depth -> Types.ty
20                              -> PLambdaType.lty,                              -> PLambdaType.lty,
21                     strLty : flexmap * Modules.Structure                     strLty : primaryEnv * Modules.Structure
22                              * DebIndex.depth                              * DebIndex.depth
23                              * ElabUtil.compInfo -> PLambdaType.lty,                              * ElabUtil.compInfo -> PLambdaType.lty,
24                     fctLty : flexmap * Modules.Functor                     fctLty : primaryEnv * Modules.Functor
25                              * DebIndex.depth                              * DebIndex.depth
26                              * ElabUtil.compInfo -> PLambdaType.lty}                              * ElabUtil.compInfo -> PLambdaType.lty}
27  end (* signature TRANSTYPES *)  end (* signature TRANSTYPES *)
# Line 138  Line 138 
138        end        end
139    | tpsKnd _ = bug "unexpected tycpath parameters in tpsKnd" *)    | tpsKnd _ = bug "unexpected tycpath parameters in tpsKnd" *)
140    
141    fun toPrimaryEnv(_,[]) = []
142      | toPrimaryEnv([], fct::fcts) = (FormalFct fct)::toPrimaryEnv([], fcts)
143      | toPrimaryEnv(tc::tcs, fcts) = (FormalTyc tc)::toPrimaryEnv(tcs,fcts)
144    
145  fun genTT() =  fun genTT() =
146    let    let
147    
# Line 188  Line 192 
192                        if finaldepth < 0 then bug "Invalid depth calculation"                        if finaldepth < 0 then bug "Invalid depth calculation"
193                        else  LT.tcc_var(finaldepth, num)                        else  LT.tcc_var(finaldepth, num)
194                    end                    end
195                 | (FormalTyc(GENtyc{kind=ABSTRACT(frontEndTyc),...}) =>                 | (FormalTyc(GENtyc{kind=ABSTRACT(frontEndTyc),...})) =>
196                    primary2tyc(frontEndTyc, cur)                    primary2tyc(FormalTyc frontEndTyc, cur)
197                 | (FormalTyc(frontEndTyc)) => tycTyc(penv, frontEndTyc, cur)                 | (FormalTyc(frontEndTyc)) => tycTyc(penv, frontEndTyc, cur)
198                 | (FormalFct _) => bug "unimplemented")                 | (FormalFct _) => bug "unimplemented")
199      in primary2tyc p      in primary2tyc (p, d)
200      end      end
201    
202  (*  (*
# Line 200  Line 204 
204    Stats.doPhase(Stats.makePhase "Compiler 043 1-tycTyc") tycTyc0 x    Stats.doPhase(Stats.makePhase "Compiler 043 1-tycTyc") tycTyc0 x
205  *)  *)
206    
207  and tycTyc(fm : flexmap, tc : Types.tycon, d) =  and tycTyc(fm : primaryEnv, tc : Types.tycon, d) =
208    let fun dtsTyc nd ({dcons: dconDesc list, arity=i, ...} : dtmember) =    let fun dtsTyc nd ({dcons: dconDesc list, arity=i, ...} : dtmember) =
209              let val nnd = if i=0 then nd else DI.next nd              let val nnd = if i=0 then nd else DI.next nd
210                  fun f ({domain=NONE, rep, name}, r) = (LT.tcc_unit)::r                  fun f ({domain=NONE, rep, name}, r) = (LT.tcc_unit)::r
# Line 263  Line 267 
267              end              end
268  *)  *)
269    
270        fun h (_,PRIMITIVE pt, _) = LT.tcc_prim (PrimTyc.pt_fromint pt)        fun h (_, _,PRIMITIVE pt, _) = LT.tcc_prim (PrimTyc.pt_fromint pt)
271          | h (_,DATATYPE {index, family, freetycs, stamps, root}, _) =          | h (_, _,DATATYPE {index, family, freetycs, stamps, root}, _) =
272                let val tc = dtsFam (freetycs, family)                let val tc = dtsFam (freetycs, family)
273                    val n = Vector.length stamps                    val n = Vector.length stamps
274                    val names = Vector.map (fn ({tycname,...}: dtmember) =>                    val names = Vector.map (fn ({tycname,...}: dtmember) =>
# Line 273  Line 277 
277                    (* invariant: n should be the number of family members *)                    (* invariant: n should be the number of family members *)
278                 in LT.tcc_fix((n, names, tc, (map g freetycs)), index)                 in LT.tcc_fix((n, names, tc, (map g freetycs)), index)
279                end                end
280          | h (_,ABSTRACT tc, 0) = (g tc)          | h (_, _,ABSTRACT tc, 0) = (g tc)
281                (*>>> LT.tcc_abs(g tc) <<<*)                (*>>> LT.tcc_abs(g tc) <<<*)
282          | h (_,ABSTRACT tc, n) = (g tc)          | h (_, _,ABSTRACT tc, n) = (g tc)
283                (*>>> we tempoarily turned off the use of abstract tycons in                (*>>> we tempoarily turned off the use of abstract tycons in
284                      the intermediate language; proper support of ML-like                      the intermediate language; proper support of ML-like
285                      abstract types in the IL may require changes to the                      abstract types in the IL may require changes to the
# Line 289  Line 293 
293                end                end
294                <<<*)                <<<*)
295          (* | h (TP.FLEXTYC tp, _) = tpsTyc d tp *)          (* | h (TP.FLEXTYC tp, _) = tpsTyc d tp *)
296          | h (stmp,FORMAL, n) =          | h (tycon, stmp,FORMAL, n) =
297            (case FTM.find(fm, stmp)              (debugmsg ("--tycTyc found "^
             of NONE => (debugmsg ("--tycTyc unable to find "^  
                                   Stamps.toShortString stmp);  
                         bug ("unexpected FORMAL kind in tycTyc-h"))  
              | SOME tp => (debugmsg ("--tycTyc found "^  
298                                       Stamps.toShortString stmp);                                       Stamps.toShortString stmp);
299                             tpsTyc fm d tp))               tpsTyc fm d (FormalTyc tycon))
300          | h (_,TEMP, _) = bug "unexpected TEMP kind in tycTyc-h"          | h (_, _,TEMP, _) = bug "unexpected TEMP kind in tycTyc-h"
301    
302        and g (tycon as GENtyc {stamp, arity, kind, ...}) =        and g (tycon as GENtyc {stamp, arity, kind, ...}) =
303            (case kind of            (case kind of
304                 k as DATATYPE _ =>                 k as DATATYPE _ =>
305                 if TU.eqTycon(tycon, BT.refTycon) then LT.tcc_prim(PT.ptc_ref)                 if TU.eqTycon(tycon, BT.refTycon) then LT.tcc_prim(PT.ptc_ref)
306                 else h(stamp,k,arity)                 else h(tycon,stamp,k,arity)
307               | k => h(stamp, k, arity))               | k => h(tycon,stamp, k, arity))
308          | g (DEFtyc{tyfun, ...}) = tfTyc(fm, tyfun, d)          | g (DEFtyc{tyfun, ...}) = tfTyc(fm, tyfun, d)
309          | g (RECtyc i) = recTyc i          | g (RECtyc i) = recTyc i
310          | g (FREEtyc i) = freeTyc i          | g (FREEtyc i) = freeTyc i
# Line 321  Line 321 
321     in g tc     in g tc
322    end    end
323    
324  and tfTyc (fm : flexmap, TYFUN{arity=0, body}, d) = toTyc fm d body  and tfTyc (fm : primaryEnv, TYFUN{arity=0, body}, d) = toTyc fm d body
325    | tfTyc (fm, TYFUN{arity, body}, d) =    | tfTyc (fm, TYFUN{arity, body}, d) =
326        let val ks = LT.tkc_arg arity        let val ks = LT.tkc_arg arity
327         in LT.tcc_fn(ks, toTyc fm (DI.next d) body)         in LT.tcc_fn(ks, toTyc fm (DI.next d) body)
328        end        end
329    
330  and toTyc (fm : flexmap) d t =  and toTyc (fm : primaryEnv) d t =
331    let val m : (tyvar * LT.tyc) list ref = ref []    let val m : (tyvar * LT.tyc) list ref = ref []
332        fun lookTv tv =        fun lookTv tv =
333          let val xxx = !m          let val xxx = !m
# Line 390  Line 390 
390     in g t     in g t
391    end (* toTyc *)    end (* toTyc *)
392    
393  and toLty (fm : flexmap) d (POLYty {tyfun=TYFUN{arity=0, body}, ...}) =  and toLty (fm : primaryEnv) d (POLYty {tyfun=TYFUN{arity=0, body}, ...}) =
394      toLty (fm : flexmap) d body      toLty (fm : primaryEnv) d body
395    | toLty (fm : flexmap) d (POLYty {tyfun=TYFUN{arity, body},...}) =    | toLty (fm : primaryEnv) d (POLYty {tyfun=TYFUN{arity, body},...}) =
396        let val ks = LT.tkc_arg arity        let val ks = LT.tkc_arg arity
397         in LT.ltc_poly(ks, [toLty fm (DI.next d) body])         in LT.ltc_poly(ks, [toLty fm (DI.next d) body])
398        end        end
399    | toLty (fm : flexmap) d  x = LT.ltc_tyc (toTyc fm d x)    | toLty (fm : primaryEnv) d  x = LT.ltc_tyc (toTyc fm d x)
400    
401  (****************************************************************************  (****************************************************************************
402   *               TRANSLATING ML MODULES INTO FLINT TYPES                    *   *               TRANSLATING ML MODULES INTO FLINT TYPES                    *
403   ****************************************************************************)   ****************************************************************************)
404    
405  fun specLty (fm : flexmap, elements : (Symbol.symbol * spec) list, entEnv,  fun specLty (fm : primaryEnv, elements : (Symbol.symbol * spec) list, entEnv,
406               depth, compInfo) =               depth, compInfo) =
407    let val _ = debugmsg ">>specLty"    let val _ = debugmsg ">>specLty"
408        fun g ([], entEnv, ltys) = rev ltys        fun g ([], entEnv, ltys) = rev ltys
# Line 491  Line 491 
491  (* sign is paramsig  (* sign is paramsig
492     rlzn is argRlzn     rlzn is argRlzn
493   *)   *)
494  and strMetaLty (fm : flexmap, sign, rlzn as { entities, ... }: strEntity,  and strMetaLty (fm : primaryEnv, sign, rlzn as { entities, ... }: strEntity,
495                  depth, compInfo, envop) =                  depth, compInfo, envop) =
496      case (sign, ModulePropLists.strEntityLty rlzn) of      case (sign, ModulePropLists.strEntityLty rlzn) of
497          (_, SOME (lt, od)) => LT.lt_adj(lt, od, depth)          (_, SOME (lt, od)) => LT.lt_adj(lt, od, depth)
# Line 509  Line 509 
509          end          end
510        | _ => bug "unexpected sign and rlzn in strMetaLty"        | _ => bug "unexpected sign and rlzn in strMetaLty"
511    
512  and strRlznLty (fm : flexmap, sign, rlzn : strEntity, depth, compInfo) =  and strRlznLty (fm : primaryEnv, sign, rlzn : strEntity, depth, compInfo) =
513      case (sign, ModulePropLists.strEntityLty rlzn) of      case (sign, ModulePropLists.strEntityLty rlzn) of
514          (sign, SOME (lt,od)) => LT.lt_adj(lt, od, depth)          (sign, SOME (lt,od)) => LT.lt_adj(lt, od, depth)
515    
# Line 533  Line 533 
533        | _ => (debugmsg ">>strRlznLty[strEntityLty NONE]";        | _ => (debugmsg ">>strRlznLty[strEntityLty NONE]";
534                strMetaLty(fm, sign, rlzn, depth, compInfo, NONE))                strMetaLty(fm, sign, rlzn, depth, compInfo, NONE))
535    
536  and fctRlznLty (fm : flexmap, sign, rlzn, depth, compInfo) =  and fctRlznLty (fm : primaryEnv, sign, rlzn, depth, compInfo) =
537      case (sign, ModulePropLists.fctEntityLty rlzn, rlzn) of      case (sign, ModulePropLists.fctEntityLty rlzn, rlzn) of
538          (sign, SOME (lt, od), _) => LT.lt_adj(lt, od, depth)          (sign, SOME (lt, od), _) => LT.lt_adj(lt, od, depth)
539        | (fs as FSIG{paramsig, bodysig, ...}, _,        | (fs as FSIG{paramsig, bodysig, ...}, _,
540           {closureEnv=env, exp=LAMBDA{primaries,...}, ...}) =>           {closureEnv=env, ...}) =>
541          let val _ = debugmsg ">>fctRlznLty[instParam]"          let val _ = debugmsg ">>fctRlznLty[instParam]"
542              val nd = DI.next depth              val nd = DI.next depth
543    
# Line 551  Line 551 
551                 partially applied curried functors.                 partially applied curried functors.
552               *)               *)
553    
554              val {rlzn=paramRlzn, primaries=_} =              val {rlzn=paramRlzn, primaries} =
555                  INS.instFormal{sign=paramsig,entEnv=env,                  INS.instFormal{sign=paramsig,entEnv=env,
556                                 rpath=InvPath.IPATH[], compInfo=compInfo,                                 rpath=InvPath.IPATH[], compInfo=compInfo,
557                                 region=SourceMap.nullRegion}                                 region=SourceMap.nullRegion}
558              (* val (tps, ftmap1) = RepTycProps.getTk(fs, paramRlzn, depth)              (* val (tps, ftmap1) = RepTycProps.getTk(fs, paramRlzn, depth)
559              val fm = FTM.unionWith (fn(tp1,tp2)=> tp1) (fm, ftmap1) *)              val fm = FTM.unionWith (fn(tp1,tp2)=> tp1) (fm, ftmap1) *)
560              val _ = debugmsg ">>tpsKnd"              val _ = debugmsg ">>tpsKnd"
561              val ks = map tpsKnd primaries              val ks = map tpsKnd (toPrimaryEnv primaries)
562    
563              val _ = if !debugging              val _ = if !debugging
564                      then (debugmsg "====================";                      then (debugmsg "====================";
# Line 576  Line 576 
576                      else ()                      else ()
577    
578              val _ = debugmsg ">>strMetaLty"              val _ = debugmsg ">>strMetaLty"
579              val paramLty = strMetaLty(fm, paramsig, primaries, nd, compInfo,              val paramLty = strMetaLty(fm, paramsig, paramRlzn, nd, compInfo,
580                                       SOME env)                                       SOME env)
581                  handle _ => bug "fctRlznLty 2"                  handle _ => bug "fctRlznLty 2"
582    
# Line 611  Line 611 
611          end          end
612        | _ => bug "fctRlznLty"        | _ => bug "fctRlznLty"
613    
614  and strLty (fm : flexmap, str as STR { sign, rlzn, ... }, depth, compInfo) =  and strLty (fm : primaryEnv, str as STR { sign, rlzn, ... }, depth, compInfo) =
615      (case ModulePropLists.strEntityLty rlzn of      (case ModulePropLists.strEntityLty rlzn of
616           SOME (lt, od) => LT.lt_adj(lt, od, depth)           SOME (lt, od) => LT.lt_adj(lt, od, depth)
617         | NONE =>         | NONE =>
# Line 624  Line 624 
624           end)           end)
625    | strLty _ = bug "unexpected structure in strLty"    | strLty _ = bug "unexpected structure in strLty"
626    
627  and fctLty (fm : flexmap, fct as FCT { sign, rlzn, ... }, depth, compInfo) =  and fctLty (fm : primaryEnv, fct as FCT { sign, rlzn, ... }, depth, compInfo) =
628      (debugmsg ">>fctLty";      (debugmsg ">>fctLty";
629       (case ModulePropLists.fctEntityLty rlzn of       (case ModulePropLists.fctEntityLty rlzn of
630           SOME (lt,od) => (debugmsg "--fctLty[proplist] ";           SOME (lt,od) => (debugmsg "--fctLty[proplist] ";

Legend:
Removed from v.3357  
changed lines
  Added in v.3358

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