Mercurial > urweb

comparison src/cjrize.sml @ 196:890a61991263

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Lists all the way through
author Adam Chlipala <adamc@hcoop.net>
date Sat, 09 Aug 2008 16:48:32 -0400
parents 8e9f97508f0d
children ab86aa858e6c
comparison
equal deleted inserted replaced
195:85b5f663bb86 196:890a61991263
28 structure Cjrize :> CJRIZE = struct 28 structure Cjrize :> CJRIZE = struct
29 29
30 structure L = Mono 30 structure L = Mono
31 structure L' = Cjr 31 structure L' = Cjr
32 32
33 structure IM = IntBinaryMap
34
33 structure Sm :> sig 35 structure Sm :> sig
34 type t 36 type t
35 37
36 val empty : t 38 val empty : t
37 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
59 61
60 fun declares (_, _, ds) = ds 62 fun declares (_, _, ds) = ds
61 63
62 end 64 end
63 65
64 fun cifyTyp ((t, loc), sm) = 66 fun cifyTyp x =
65 case t of 67 let
66 L.TFun (t1, t2) => 68 fun cify dtmap ((t, loc), sm) =
67 let 69 case t of
68 val (t1, sm) = cifyTyp (t1, sm) 70 L.TFun (t1, t2) =>
69 val (t2, sm) = cifyTyp (t2, sm) 71 let
70 in 72 val (t1, sm) = cify dtmap (t1, sm)
71 ((L'.TFun (t1, t2), loc), sm) 73 val (t2, sm) = cify dtmap (t2, sm)
72 end 74 in
73 | L.TRecord xts => 75 ((L'.TFun (t1, t2), loc), sm)
74 let 76 end
75 val old_xts = xts 77 | L.TRecord xts =>
76 val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) => 78 let
77 let 79 val old_xts = xts
78 val (t, sm) = cifyTyp (t, sm) 80 val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
79 in 81 let
80 ((x, t), sm) 82 val (t, sm) = cify dtmap (t, sm)
81 end) 83 in
82 sm xts 84 ((x, t), sm)
83 val (sm, si) = Sm.find (sm, old_xts, xts) 85 end)
84 in 86 sm xts
85 ((L'.TRecord si, loc), sm) 87 val (sm, si) = Sm.find (sm, old_xts, xts)
86 end 88 in
87 | L.TDatatype (dk, n, xncs) => 89 ((L'.TRecord si, loc), sm)
88 let 90 end
89 val (xncs, sm) = ListUtil.foldlMap (fn ((x, n, to), sm) => 91 | L.TDatatype (n, ref (dk, xncs)) =>
90 case to of 92 (case IM.find (dtmap, n) of
91 NONE => ((x, n, NONE), sm) 93 SOME r => ((L'.TDatatype (dk, n, r), loc), sm)
92 | SOME t => 94 | NONE =>
93 let 95 let
94 val (t, sm) = cifyTyp (t, sm) 96 val r = ref []
95 in 97 val dtmap = IM.insert (dtmap, n, r)
96 ((x, n, SOME t), sm) 98
97 end) 99 val (xncs, sm) = ListUtil.foldlMap (fn ((x, n, to), sm) =>
98 sm xncs 100 case to of
99 in 101 NONE => ((x, n, NONE), sm)
100 ((L'.TDatatype (dk, n, xncs), loc), sm) 102 | SOME t =>
101 end 103 let
102 | L.TFfi mx => ((L'.TFfi mx, loc), sm) 104 val (t, sm) = cify dtmap (t, sm)
105 in
106 ((x, n, SOME t), sm)
107 end)
108 sm xncs
109 in
110 r := xncs;
111 ((L'.TDatatype (dk, n, r), loc), sm)
112 end)
113 | L.TFfi mx => ((L'.TFfi mx, loc), sm)
114 in
115 cify IM.empty x
116 end
103 117
104 val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan) 118 val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan)
105 119
106 fun cifyPatCon (pc, sm) = 120 fun cifyPatCon (pc, sm) =
107 case pc of 121 case pc of
354 (NONE, SOME (ek, "/" ^ s, n, ts), sm) 368 (NONE, SOME (ek, "/" ^ s, n, ts), sm)
355 end 369 end
356 370
357 fun cjrize ds = 371 fun cjrize ds =
358 let 372 let
359 val (ds, ps, sm) = foldl (fn (d, (ds, ps, sm)) => 373 val (dsF, ds, ps, sm) = foldl (fn (d, (dsF, ds, ps, sm)) =>
360 let 374 let
361 val (dop, pop, sm) = cifyDecl (d, sm) 375 val (dop, pop, sm) = cifyDecl (d, sm)
362 val ds = case dop of 376 val (dsF, ds) = case dop of
363 NONE => ds 377 NONE => (dsF, ds)
364 | SOME d => d :: ds 378 | SOME (d as (L'.DDatatype (dk, x, n, _), loc)) =>
365 val ps = case pop of 379 ((L'.DDatatypeForward (dk, x, n), loc) :: dsF,
366 NONE => ps 380 d :: ds)
367 | SOME p => p :: ps 381 | SOME d => (dsF, d :: ds)
368 in 382 val ps = case pop of
369 (ds, ps, sm) 383 NONE => ps
370 end) 384 | SOME p => p :: ps
371 ([], [], Sm.empty) ds 385 in
386 (dsF, ds, ps, sm)
387 end)
388 ([], [], [], Sm.empty) ds
372 in 389 in
373 (List.revAppend (map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm), 390 (List.revAppend (dsF,
374 rev ds), 391 List.revAppend (map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm),
392 rev ds)),
375 ps) 393 ps)
376 end 394 end
377 395
378 end 396 end