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

Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/kernel/ltyextern.sml

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

revision 2021, Thu Aug 17 20:36:49 2006 UTC revision 2022, Thu Aug 17 20:54:13 2006 UTC
# Line 59  Line 59 
59  (********************************************************************  (********************************************************************
60   *                      KIND-CHECKING ROUTINES                      *   *                      KIND-CHECKING ROUTINES                      *
61   ********************************************************************)   ********************************************************************)
62  exception TkTycChk  exception TkTycChk of string
63  exception LtyAppChk  exception LtyAppChk
64    
65  (* tkSubkind returns true if k1 is a subkind of k2, or if they are  (* tkSubkind returns true if k1 is a subkind of k2, or if they are
# Line 80  Line 80 
80        | (LT.TK_SEQ ks1, LT.TK_SEQ ks2) =>        | (LT.TK_SEQ ks1, LT.TK_SEQ ks2) =>
81            tksSubkind (ks1, ks2)            tksSubkind (ks1, ks2)
82        | (LT.TK_FUN (ks1, k1'), LT.TK_FUN (ks2, k2')) =>        | (LT.TK_FUN (ks1, k1'), LT.TK_FUN (ks2, k2')) =>
83            tksSubkind (ks1, ks2) andalso (* contravariant *)            tksSubkind (ks2, ks1) andalso (* contravariant *)
84            tkSubkind (k1', k2')            tkSubkind (k1', k2')
85        | _ => false        | _ => false
86    
# Line 90  Line 90 
90  (* assert that k1 is a subkind of k2 *)  (* assert that k1 is a subkind of k2 *)
91  fun tkAssertSubkind (k1, k2) =  fun tkAssertSubkind (k1, k2) =
92      if tkSubkind (k1, k2) then ()      if tkSubkind (k1, k2) then ()
93      else raise TkTycChk      else raise TkTycChk "Subkind assertion failed!"
94    
95  (* assert that a kind is monomorphic *)  (* assert that a kind is monomorphic *)
96  fun tkAssertIsMono k =  fun tkAssertIsMono k =
97      if tkIsMono k then ()      if tkIsMono k then ()
98      else raise TkTycChk      else raise TkTycChk "Mono assertion failed!"
99    
100  (* select the ith element from a kind sequence *)  (* select the ith element from a kind sequence *)
101  fun tkSel (tk, i) =  fun tkSel (tk, i) =
102    (case (tk_out tk)    (case (tk_out tk)
103      of (LT.TK_SEQ ks) => (List.nth(ks, i) handle _ => raise TkTycChk)      of (LT.TK_SEQ ks) => (List.nth(ks, i) handle Subscript => raise TkTycChk "Invalid TC_SEQ index")
104       | _ => raise TkTycChk)       | _ => raise TkTycChk "Projecting out of non-tyc sequence")
105    
106  fun tks_eqv (ks1, ks2) = tk_eqv(tkc_seq ks1, tkc_seq ks2)  fun tks_eqv (ks1, ks2) = tk_eqv(tkc_seq ks1, tkc_seq ks2)
107    
108  fun tkApp (tk, tks) =  fun tkApp (tk, tks) =
109    (case (tk_out tk)    (case (tk_out tk)
110      of LT.TK_FUN(a, b) => if tks_eqv(a, tks) then b else raise TkTycChk      of LT.TK_FUN(a, b) => if tks_eqv(a, tks) then b else raise TkTycChk "Param/Arg Tyc Kind mismatch"
111       | _ => raise TkTycChk)       | _ => raise TkTycChk "Application of non-TK_FUN")
112    
113  (* 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
114   * kind `tk'.   * kind `tk'.
# Line 116  Line 116 
116  fun tkApp (tk, tks) =  fun tkApp (tk, tks) =
117    (case (tk_out tk)    (case (tk_out tk)
118      of LT.TK_FUN(a, b) =>      of LT.TK_FUN(a, b) =>
119         if tksSubkind(tks, a) then b else raise TkTycChk         if tksSubkind(tks, a) then b else raise TkTycChk "Param/Arg Tyc Kind mismatch"
120       | _ => raise TkTycChk)       | _ => raise TkTycChk "Application of non-TK_FUN")
121    
122  (* Kind-checking naturally requires traversing type graphs.  to avoid  (* Kind-checking naturally requires traversing type graphs.  to avoid
123   * re-traversing bits of the dag, we use a dictionary to memoize the   * re-traversing bits of the dag, we use a dictionary to memoize the
# Line 213  Line 213 
213                  (List.app (tkAssertIsMono o g) tcs;                  (List.app (tkAssertIsMono o g) tcs;
214                   tkc_mono)                   tkc_mono)
215                | LT.TC_FIX ((n, tc, ts), i) =>                | LT.TC_FIX ((n, tc, ts), i) =>
216                  let val k = g tc                  let (* Kind check generator tyc *)
217                        val k = g tc
218                        (* Kind check freetycs *)
219                      val nk =                      val nk =
220                          case ts of                          case ts of
221                              [] => k                              [] => k
# Line 226  Line 228 
228                                      [x] => x                                      [x] => x
229                                    | _ => tkc_seq a                                    | _ => tkc_seq a
230                          in                          in
231                                (* Kind check recursive tyc app ??*)
232                              if tkSubkind(arg, b) then (* order? *)                              if tkSubkind(arg, b) then (* order? *)
233                                  (if n = 1 then b else tkSel(arg, i))                                  (if n = 1 then b else tkSel(arg, i))
234                              else raise TkTycChk                              else raise TkTycChk "Recursive app mismatch"
235                          end                          end
236                        | _ => raise TkTycChk                        | _ => raise TkTycChk "FIX with no generator"
237                  end                  end
238                | LT.TC_ABS tc =>                | LT.TC_ABS tc =>
239                  (tkAssertIsMono (g tc);                  (tkAssertIsMono (g tc);

Legend:
Removed from v.2021  
changed lines
  Added in v.2022

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