Mercurial > urweb

comparison src/cjrize.sml @ 757:fa2019a63ea4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Basis.list
author Adam Chlipala <adamc@hcoop.net>
date Thu, 30 Apr 2009 11:07:29 -0400
parents 8688e01ae469
children d8f58d488cfb
comparison
equal deleted inserted replaced
756:8ce31c052dce 757:fa2019a63ea4
35 structure Sm :> sig 35 structure Sm :> sig
36 type t 36 type t
37 37
38 val empty : t 38 val empty : t
39 val find : t * (string * L.typ) list * (string * L'.typ) list -> t * int 39 val find : t * (string * L.typ) list * (string * L'.typ) list -> t * int
40 val findList : t * L.typ * L'.typ -> t * int
40 41
41 val declares : t -> (int * (string * L'.typ) list) list 42 val declares : t -> (int * (string * L'.typ) list) list
42 val clearDeclares : t -> t 43 val clearDeclares : t -> t
43 end = struct 44 end = struct
44 45
45 structure FM = BinaryMapFn(struct 46 structure FM = BinaryMapFn(struct
46 type ord_key = L.typ 47 type ord_key = L.typ
47 val compare = MonoUtil.Typ.compare 48 val compare = MonoUtil.Typ.compare
48 end) 49 end)
49 50
50 type t = int * int FM.map * (int * (string * L'.typ) list) list 51 type t = {
51 52 count : int,
52 val empty : t = (1, FM.insert (FM.empty, (L.TRecord [], ErrorMsg.dummySpan), 0), []) 53 normal : int FM.map,
53 54 lists : int FM.map,
54 fun find ((n, m, ds), xts, xts') = 55 decls : (int * (string * L'.typ) list) list
56 }
57
58 val empty : t = {
59 count = 1,
60 normal = FM.insert (FM.empty, (L.TRecord [], ErrorMsg.dummySpan), 0),
61 lists = FM.empty,
62 decls = []
63 }
64
65 fun find (v as {count, normal, decls, lists}, xts, xts') =
55 let 66 let
56 val t = (L.TRecord xts, ErrorMsg.dummySpan) 67 val t = (L.TRecord xts, ErrorMsg.dummySpan)
57 in 68 in
58 case FM.find (m, t) of 69 case FM.find (normal, t) of
59 NONE => ((n+1, FM.insert (m, t, n), (n, xts') :: ds), n) 70 SOME i => (v, i)
60 | SOME i => ((n, m, ds), i) 71 | NONE => ({count = count+1,
72 normal = FM.insert (normal, t, count),
73 lists = lists,
74 decls = (count, xts') :: decls},
75 count)
61 end 76 end
62 77
63 fun declares (_, _, ds) = ds 78 fun findList (v as {count, normal, decls, lists}, t, t') =
64 79 case FM.find (lists, t) of
65 fun clearDeclares (n, m, _) = (n, m, []) 80 SOME i => (v, i)
81 | NONE =>
82 let
83 val xts = [("1", t), ("2", (L.TList t, #2 t))]
84 val xts' = [("1", t'), ("2", (L'.TList (t', count), #2 t'))]
85 in
86 ({count = count+1,
87 normal = FM.insert (normal, (L.TRecord xts, ErrorMsg.dummySpan), count),
88 lists = FM.insert (lists, t, count),
89 decls = (count, xts') :: decls},
90 count)
91 end
92
93 fun declares (v : t) = #decls v
94
95 fun clearDeclares (v : t) = {count = #count v,
96 normal = #normal v,
97 lists = #lists v,
98 decls = []}
66 99
67 end 100 end
68 101
69 fun cifyTyp x = 102 fun cifyTyp x =
70 let 103 let
118 let 151 let
119 val (t, sm) = cify dtmap (t, sm) 152 val (t, sm) = cify dtmap (t, sm)
120 in 153 in
121 ((L'.TOption t, loc), sm) 154 ((L'.TOption t, loc), sm)
122 end 155 end
156 | L.TList t =>
157 let
158 val (t', sm) = cify dtmap (t, sm)
159 val (sm, si) = Sm.findList (sm, t, t')
160 in
161 ((L'.TList (t', si), loc), sm)
162 end
123 | L.TSource => ((L'.TFfi ("Basis", "int"), loc), sm) 163 | L.TSource => ((L'.TFfi ("Basis", "int"), loc), sm)
124 | L.TSignal _ => raise Fail "Cjrize: TSignal remains" 164 | L.TSignal _ => raise Fail "Cjrize: TSignal remains"
125 in 165 in
126 cify IM.empty x 166 cify IM.empty x
127 end 167 end