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/kernel/ltyextern.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/FLINT/kernel/ltyextern.sml

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

revision 65, Wed Apr 1 20:57:44 1998 UTC revision 71, Fri Apr 3 01:57:57 1998 UTC
# Line 49  Line 49 
49  fun lt_pinst (lt : lty, ts : tyc list) =  fun lt_pinst (lt : lty, ts : tyc list) =
50    (case lt_inst (lt, ts) of [y] => y | _ => bug "unexpected lt_pinst")    (case lt_inst (lt, ts) of [y] => y | _ => bug "unexpected lt_pinst")
51    
 val lt_inst_st = (map lt_norm) o lt_inst   (* strict instantiation *)  
 val lt_pinst_st = lt_norm o lt_pinst   (* strict instantiation *)  
   
52  (********************************************************************  (********************************************************************
53   *                      KIND-CHECKING ROUTINES                      *   *                      KIND-CHECKING ROUTINES                      *
54   ********************************************************************)   ********************************************************************)
# Line 99  Line 96 
96      of (LK.TK_SEQ ks) => (List.nth(ks, i) handle _ => raise TkTycChk)      of (LK.TK_SEQ ks) => (List.nth(ks, i) handle _ => raise TkTycChk)
97       | _ => raise TkTycChk)       | _ => raise TkTycChk)
98    
99    fun tks_eqv (ks1, ks2) = tk_eqv(tkc_seq ks1, tkc_seq ks2)
100    
101    fun tkApp (tk, tks) =
102      (case (tk_out tk)
103        of LK.TK_FUN(a, b) => if tks_eqv(a, tks) then b else raise TkTycChk
104         | _ => raise TkTycChk)
105    
106  (* check the application of tycs of kinds `tks' to a type function of  (* check the application of tycs of kinds `tks' to a type function of
107   * kind `tk'.   * kind `tk'.
108   *)   *)
# Line 228  Line 232 
232                  (List.app (tkAssertIsMono o g) ts1;                  (List.app (tkAssertIsMono o g) ts1;
233                   List.app (tkAssertIsMono o g) ts2;                   List.app (tkAssertIsMono o g) ts2;
234                   tkc_mono)                   tkc_mono)
235                | _ => bug "unexpected TC_ENV or TC_CONT in tkTyc"                | LK.TC_TOKEN(_, tc) =>
236                    (tkAssertIsMono (g tc);
237                     tkc_mono)
238                  | LK.TC_PARROW _ => bug "unexpected TC_PARROW in tkTyc"
239                  | LK.TC_ENV _ => bug "unexpected TC_ENV in tkTyc"
240                  | LK.TC_IND _ => bug "unexpected TC_IND in tkTyc"
241                  | LK.TC_CONT _ => bug "unexpected TC_CONT in tkTyc"
242      in      in
243          Memo.recallOrCompute (dict, kenv, t, mk)          Memo.recallOrCompute (dict, kenv, t, mk)
244      end      end
# Line 383  Line 393 
393  fun ltd_rkind (lt, i) = lt_select (lt, i)  fun ltd_rkind (lt, i) = lt_select (lt, i)
394    
395  (****************************************************************************  (****************************************************************************
  *        THE FOLLOWING UTILITY FUNCTIONS WILL SOON BE OBSOLETE             *  
  ****************************************************************************)  
   
 (** a version of ltc_arrow with singleton argument and return result *)  
 val ltc_arw = ltc_parrow  
   
 (** not knowing what FUNCTION this is, to build a fct or an arw *)  
 fun ltc_fun (x, y) =  
   (case (lt_out x, lt_out y)  
     of (LK.LT_TYC _, LK.LT_TYC _) => ltc_parrow(x, y)  
      | _ => ltc_pfct(x, y))  
   
 (* lt_arrow used by chkflint.sml, checklty.sml, chkplexp.sml, convert.sml  
  * and wrapping.sml only  
  *)  
 fun lt_arrow t =  
   (case (lt_out t)  
     of (LK.LT_FCT([t1], [t2])) => (t1, t2)  
      | (LK.LT_FCT(_, _)) => bug "unexpected case in lt_arrow"  
      | (LK.LT_CONT [t]) => (t, ltc_void)  
      | _ => (ltd_parrow t) handle _ =>  
                 bug ("unexpected lt_arrow --- more info: \n\n"  
                      ^ (lt_print t) ^ "\n\n"))  
   
 (* lt_arrowN used by flintnm.sml and ltysingle.sml only, should go away soon *)  
 fun lt_arrowN t =  
   (case (lt_out t)  
     of (LK.LT_FCT(ts1, ts2)) => (ts1, ts2)  
      | (LK.LT_CONT ts) => (ts, [])  
      | _ => (let val (_, s1, s2) = ltd_arrow t  
               in (s1, s2)  
              end))  
   
   
   
 (****************************************************************************  
396   *             UTILITY FUNCTIONS USED BY POST-REPRESENTATION ANALYSIS       *   *             UTILITY FUNCTIONS USED BY POST-REPRESENTATION ANALYSIS       *
397   ****************************************************************************)   ****************************************************************************)
398  (** find out what is the appropriate primop given a tyc *)  (** find out what is the appropriate primop given a tyc *)
# Line 450  Line 424 
424      of LK.TK_MONO => ltc_int      of LK.TK_MONO => ltc_int
425       | LK.TK_BOX => ltc_int       | LK.TK_BOX => ltc_int
426       | LK.TK_SEQ ks => ltc_tuple (map tk_lty ks)       | LK.TK_SEQ ks => ltc_tuple (map tk_lty ks)
427       | LK.TK_FUN (ks, k) => ltc_parrow(ltc_tuple(map tk_lty ks), tk_lty k))       | LK.TK_FUN (ks, k) =>
428             ltc_arrow(ffc_fixed, [ltc_tuple(map tk_lty ks)], [tk_lty k]))
429    
430    
431  (* val tnarrow_gen : unit -> ((tyc -> tyc) * (lty -> lty) * (unit->unit)) *)  (* tnarrow_gen : unit -> ((tyc -> tyc) * (lty -> lty) * (unit->unit)) *)
432  fun tnarrow_gen () =  fun tnarrow_gen () =
433    let fun tcNarrow tcf t =    let fun tcNarrow tcf t =
434          (case (tc_out t)          (case (tc_out t)
# Line 461  Line 436 
436                 if PT.isvoid pt then tcc_void else t                 if PT.isvoid pt then tcc_void else t
437             | LK.TC_TUPLE (_, tcs) => tcc_tuple (map tcf tcs)             | LK.TC_TUPLE (_, tcs) => tcc_tuple (map tcf tcs)
438             | LK.TC_ARROW (r, ts1, ts2) =>             | LK.TC_ARROW (r, ts1, ts2) =>
439                 tcc_arrow(r, map tcf ts1, map tcf ts2)                 tcc_arrow(ffc_fixed, map tcf ts1, map tcf ts2)
440             | _ => tcc_void)             | _ => tcc_void)
441    
442        fun ltNarrow (tcf, ltf) t =        fun ltNarrow (tcf, ltf) t =
# Line 477  Line 452 
452             | LK.LT_ENV _ => bug "unexpected ENVs in ltNarrow")             | LK.LT_ENV _ => bug "unexpected ENVs in ltNarrow")
453    
454        val {tc_map, lt_map} = LtyDict.tmemo_gen {tcf=tcNarrow, ltf=ltNarrow}        val {tc_map, lt_map} = LtyDict.tmemo_gen {tcf=tcNarrow, ltf=ltNarrow}
455     in (tc_map, lt_map, fn ()=>())     in (tc_map o tc_norm, lt_map o lt_norm, fn ()=>())
456    end (* function tnarrow_gen *)    end (* function tnarrow_gen *)
457    
458    (* twrap_gen   : bool -> ((tyc -> tyc) * (lty -> lty) *
459     *                        (tyc -> tyc) * (lty -> lty) * (unit -> unit))
460     *)
461    fun twrap_gen bbb =
462      let fun tc_wmap (w, u) t =
463            (case (tc_out t)
464              of (LK.TC_VAR _ | LK.TC_NVAR _) => t
465               | LK.TC_PRIM pt => if PT.unboxed pt then tcc_wrap t else t
466               | LK.TC_FN (ks, tc) => tcc_fn(ks, w tc) (* impossible case *)
467               | LK.TC_APP (tc, tcs) => tcc_app(w tc, map w tcs)
468               | LK.TC_SEQ tcs => tcc_seq(map w tcs)
469               | LK.TC_PROJ (tc, i) => tcc_proj(w tc, i)
470               | LK.TC_SUM tcs => tcc_sum (map w tcs)
471               | LK.TC_FIX ((n,tc,ts), i) =>
472                   tcc_fix((n, tc_norm (u tc), map w ts), i)
473    
474               | LK.TC_TUPLE (_, ts) => tcc_wrap(tcc_tuple (map w ts)) (* ? *)
475               | LK.TC_ARROW (LK.FF_VAR(b1,b2), ts1, ts2) =>
476                   let val nts1 =    (* too specific ! *)
477                         (case ts1 of [t11,t12] => [w t11, w t12]
478                                    | _ => [w (LK.tc_autotuple ts1)])
479                       val nts2 = [w (LK.tc_autotuple ts2)]
480                       val nt = tcc_arrow(ffc_fixed, nts1, nts2)
481                    in if b1 then nt else tcc_wrap nt
482                   end
483               | LK.TC_ARROW (LK.FF_FIXED, _, _) =>
484                    bug "unexpected TC_FIXED_ARROW in tc_umap"
485               | LK.TC_TOKEN (k, t) => bug "unexpected token tyc in tc_wmap"
486               | LK.TC_BOX _ => bug "unexpected TC_BOX in tc_wmap"
487               | LK.TC_ABS _ => bug "unexpected TC_ABS in tc_wmap"
488               | _ => bug "unexpected other tycs in tc_wmap")
489    
490          fun tc_umap (u, w) t =
491            (case (tc_out t)
492              of (LK.TC_VAR _ | LK.TC_NVAR _ | LK.TC_PRIM _) => t
493               | LK.TC_FN (ks, tc) => tcc_fn(ks, u tc) (* impossible case *)
494               | LK.TC_APP (tc, tcs) => tcc_app(u tc, map w tcs)
495               | LK.TC_SEQ tcs => tcc_seq(map u tcs)
496               | LK.TC_PROJ (tc, i) => tcc_proj(u tc, i)
497               | LK.TC_SUM tcs => tcc_sum (map u tcs)
498               | LK.TC_FIX ((n,tc,ts), i) =>
499                   tcc_fix((n, tc_norm (u tc), map w ts), i)
500    
501               | LK.TC_TUPLE (rk, tcs) => tcc_tuple(map u tcs)
502               | LK.TC_ARROW (LK.FF_VAR(b1,b2), ts1, ts2) =>
503                   tcc_arrow(ffc_fixed, map u ts1, map u ts2)
504               | LK.TC_ARROW (LK.FF_FIXED, _, _) =>
505                   bug "unexpected TC_FIXED_ARROW in tc_umap"
506               | LK.TC_PARROW _ => bug "unexpected TC_PARROW in tc_umap"
507    
508               | LK.TC_BOX _ => bug "unexpected TC_BOX in tc_umap"
509               | LK.TC_ABS _ => bug "unexpected TC_ABS in tc_umap"
510               | LK.TC_TOKEN (k, t) =>
511                   if LK.token_eq(k, LK.wrap_token) then
512                     bug "unexpected TC_WRAP in tc_umap"
513                   else tc_inj (LK.TC_TOKEN (k, u t))
514    
515               | _ => bug "unexpected other tycs in tc_umap")
516    
517          fun lt_umap (tcf, ltf) t =
518            (case (lt_out t)
519              of LK.LT_TYC tc => ltc_tyc (tcf tc)
520               | LK.LT_STR ts => ltc_str (map ltf ts)
521               | LK.LT_FCT (ts1, ts2) => ltc_fct(map ltf ts1, map ltf ts2)
522               | LK.LT_POLY (ks, xs) => ltc_poly(ks, map ltf xs)
523               | LK.LT_PST its => ltc_pst (map (fn (i, t) => (i, ltf t)) its)
524               | LK.LT_CONT _ => bug "unexpected CNTs in lt_umap"
525               | LK.LT_IND _ => bug "unexpected INDs in lt_umap"
526               | LK.LT_ENV _ => bug "unexpected ENVs in lt_umap")
527    
528          val {tc_wmap=tcWrap, tc_umap=tcMap, lt_umap=ltMap, cleanup} =
529            LtyDict.wmemo_gen{tc_wmap=tc_wmap, tc_umap=tc_umap, lt_umap=lt_umap}
530    
531          fun ltWrap x =
532            ltw_tyc (x, (fn tc => ltc_tyc (tcWrap tc)),
533                         fn _ => bug "unexpected case in ltWrap")
534    
535       in (tcWrap o tc_norm, ltWrap o lt_norm,
536           tcMap o tc_norm, ltMap o lt_norm, cleanup)
537      end
538    
539    
540  end (* top-level local *)  end (* top-level local *)
541  end (* structure LtyExtern *)  end (* structure LtyExtern *)
542    

Legend:
Removed from v.65  
changed lines
  Added in v.71

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