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

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

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

revision 2019, Thu Aug 17 15:36:17 2006 UTC revision 2020, Thu Aug 17 19:54:34 2006 UTC
# Line 12  Line 12 
12  fun eqKind (TK_MONO, TK_MONO) = true  fun eqKind (TK_MONO, TK_MONO) = true
13    | eqKind (TK_BOX, TK_BOX) = true    | eqKind (TK_BOX, TK_BOX) = true
14    | eqKind (TK_SEQ ks, TK_SEQ ks') = List.all eqKind (ListPair.zip (ks,ks'))    | eqKind (TK_SEQ ks, TK_SEQ ks') = List.all eqKind (ListPair.zip (ks,ks'))
15    | eqKind (TK_FUN (paramks, retknd), TK_FUN (paramks', retknd')) =    | eqKind (TK_FUN (paramks, rngknd), TK_FUN (paramks', rngknd')) =
16        (List.all eqKind (ListPair.zip (paramks, paramks'))) andalso eqKind(retknd,retknd')        (List.all eqKind (ListPair.zip (paramks, paramks'))) andalso eqKind(rngknd,rngknd')
17   *)   *)
18    
19  (* lty.sml has a tk_eq "pointer" equality on normalized tkind *)  (* lty.sml has a tk_eq "pointer" equality on normalized tkind *)
20  (* ltyextern.sml has a tkSubkind and tksSubkind functions *)  (* ltyextern.sml has a tkSubkind and tksSubkind functions *)
21    
22    
23  (* ltyextern.sml has a tkTycGen() that returns a function that returns the  (* ltyextern.sml has a tkTycGen() that returns a function that returns the
24     kind of a given tyc using a given kenv *)     kind of a given tyc using a given kenv *)
25    val tkTyc = tkTycGen()
26    
27    exception KindCheck of string
28    fun error e = raise KindCheck e
29    
30  fun chkKind(tyc : tyc, kenv) =  fun chkKind(tyc : tyc, kenv) =
31        let val chkKind' = fn tyc => chkKind(tyc, kenv)
32        in
33      (case (tc_outX tyc) of      (case (tc_outX tyc) of
34           TC_VAR(n,argnum) => lookupKind(kenv, n, argnum)           TC_VAR(n,argnum) => lookupKind(kenv, n, argnum)
35         | TC_NVAR(lv) => raise Fail "Unimplemented" (* ... *)         | TC_NVAR(lv) => raise Fail "Unimplemented" (* ... *)
36         | TC_PRIM(ptyc) =>         | TC_PRIM(ptyc) =>
37             | TC_FN(paramknds, bodyTyc) =>
38               F(paramknds,
39                 chkKind(bodyTyc, tkInsert(kenv, paramknds)))
40             | TC_APP(opTyc, argTycs) =>
41               let
42                   val argKnds = map chkKind' argTycs
43               in
44                   (case chkKind opTyc of
45                        F(paramknds, rngknd) =>
46                        if LT.tksSubkind(argKnds, paramknds)
47                        then rngknd
48                        else error "Arg/param kind mismatch"
49                      | _ => error "Application of a non type \
50                                   \ function")
51               end
52             | TC_SEQ tycs => TK_SEQ(map chkKind' tycs)
53             | TC_PROJ (tyc, ind) =>
54                 (case chkKind' tyc of
55                      TK_SEQ ks =>
56                        (List.nth ks ind
57                         handle Subscript => error "PROJ bad index")
58                    | _ => error "PROJ non-seq")
59             | TC_SUM
60    

Legend:
Removed from v.2019  
changed lines
  Added in v.2020

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