Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/Semant/pickle/unpickmod.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/Semant/pickle/unpickmod.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :     (* unpickmod.sml *)
3 :    
4 :     signature UNPICKMOD =
5 :     sig
6 :    
7 :     val unpickleEnv:
8 :     SCStaticEnv.staticEnv *
9 :     {hash: PersStamps.persstamp, pickle: Word8Vector.vector}
10 :     -> StaticEnv.staticEnv
11 :    
12 :     val unpickleFLINT:
13 :     {hash: PersStamps.persstamp, pickle: Word8Vector.vector}
14 :     -> CompBasic.flint option
15 :    
16 :     end (* signature UNPICKMOD *)
17 :    
18 :     structure UnpickMod : UNPICKMOD =
19 :     struct
20 :    
21 :     local structure A = Access
22 :     structure B = Bindings
23 :     structure DI = DebIndex
24 :     structure EP = EntPath
25 :     structure ED = EntPath.EvDict
26 :     structure II = InlInfo
27 :     structure IP = InvPath
28 :     structure F = FLINT
29 :     structure LV = LambdaVar
30 :     structure LT = LtyDef (* structure LK = LtyKernel *)
31 :     structure M = Modules
32 :     structure MI = ModuleId
33 :     structure P = PrimOp
34 :     structure PS = PersStamps
35 :     structure PT = PrimTyc
36 :     structure S = Symbol
37 :     structure SP = SymPath
38 :     structure T = Types
39 :     structure TU = TypesUtil
40 :     structure V = VarCon
41 :     in
42 :    
43 :     datatype universal
44 :     = UFunctor of M.Functor
45 :     | USignature of M.Signature
46 :     | UStructure of M.Structure
47 :     | UfctSig of M.fctSig
48 :     | Uaccess of A.access
49 :     | UaccessList of A.access list
50 :     | Uarithop of P.arithop
51 :     | Ubind of S.symbol * B.binding
52 :     | UbindList of (S.symbol * B.binding) list
53 :     | Ubinding of B.binding
54 :     | Ubool of bool
55 :     | UboolList of bool list
56 :     | UboundepsElem of EP.entPath * LT.tkind
57 :     | UboundepsList of (EP.entPath * LT.tkind) list
58 :     | UboundepsOption of (EP.entPath * LT.tkind) list option
59 :     | Ucmpop of P.cmpop
60 :     | Uconrep of A.conrep
61 :     | Uconsig of A.consig
62 :     | Udatacon of V.datacon
63 :     | Uelement of S.symbol * M.spec
64 :     | Uelements of M.elements
65 :     | Uentity of M.entity
66 :     | UentityDec of M.entityDec
67 :     | UentityDecList of M.entityDec list
68 :     | UentityEnv of M.entityEnv
69 :     | UentVarOption of EP.entVar option
70 :     | UentVElist of (EP.entVar * M.entity) list
71 :     | UentVETuple of EP.entVar * M.entity
72 :     | UentityExp of M.entityExp
73 :     | UentPath of EP.entPath
74 :     | Uenv of B.binding Env.env
75 :     | Ueqprop of T.eqprop
76 :     | UfctClosure of M.fctClosure
77 :     | UfctEntity of M.fctEntity
78 :     | UfctExp of M.fctExp
79 :     | Ufixity of Fixity.fixity
80 :     | Uinl_info of II.inl_info
81 :     | Uinl_infoList of II.inl_info list
82 :     | Ulty of LT.lty
83 :     | UltyList of LT.lty list
84 :     | UltyListOption of LT.lty list option
85 :     | UldTuple of LT.lty * DI.depth
86 :     | UldOption of (LT.lty * DI.depth) option
87 :     | UldOptionList of (LT.lty * DI.depth) option list
88 :     | UintltyList of (int * LT.lty) list
89 :     | UintltyTuple of (int * LT.lty)
90 :     | Utyc of LT.tyc
91 :     | UtycList of LT.tyc list
92 :     | Utkind of LT.tkind
93 :     | UtkindList of LT.tkind list
94 :     | UtkindtycTuple of LT.tkind * LT.tyc
95 :     | UtkindtycList of (LT.tkind * LT.tyc) list
96 :     | UmodId of MI.modId
97 :     | UnameRepDomain of {name:S.symbol, rep:A.conrep, domain:T.ty option}
98 :     | UnameRepDomainList of {name:S.symbol, rep:A.conrep,
99 :     domain:T.ty option} list
100 :     | UdtFamily of T.dtypeFamily
101 :     | Udtmember of T.dtmember
102 :     | UdtmemberList of T.dtmember list
103 :     | UdtypeInfo of Stamps.stamp Vector.vector * T.dtypeFamily * T.tycon list
104 :    
105 :     | Unumkind of P.numkind
106 :     | Uoverld of {indicator: T.ty, variant: V.var}
107 :     | UoverldList of {indicator: T.ty, variant: V.var} list
108 :     | Uprimop of P.primop
109 :     | UstrDef of M.strDef
110 :     | UstrDefIntTuple of M.strDef * int
111 :     | UstrDefIntOption of (M.strDef * int) option
112 :     | UspathList of SP.path list
113 :     | UspathListList of SP.path list list
114 :     | Uspec of M.spec
115 :     | Ustamp of Stamps.stamp
116 :     | UstampExp of M.stampExp
117 :     | UstrEntity of M.strEntity
118 :     | UstrExp of M.strExp
119 :     | Usymbol of S.symbol
120 :     | UsymbolOption of S.symbol option
121 :     | UsymbolList of S.symbol list
122 :     | Uty of T.ty
123 :     | UtyList of T.ty list
124 :     | UtyOption of T.ty option
125 :     | UtycExp of M.tycExp
126 :     | Utyckind of T.tyckind
127 :     | Utycon of T.tycon
128 :     | UtyconList of T.tycon list
129 :     | Uvar of V.var
130 :     | Ulexp of F.lexp
131 :     | UlexpOption of F.lexp option
132 :     | Ufundec of F.fundec
133 :     | UfundecList of F.fundec list
134 :     | UfundecOption of F.fundec option
135 :     | Utfundec of F.tfundec
136 :     | Ufkind of F.fkind
137 :     | Urkind of F.rkind
138 :     | UintOption of int option
139 :     | UlexpList of F.lexp list
140 :     | Ufprim of F.primop
141 :     | Udict of F.dict
142 :     | Ugenop of F.dict * F.primop
143 :     | Uvalue of F.value
144 :     | UvalueList of F.value list
145 :     | Ucon of F.con * F.lexp
146 :     | Udcon of F.dcon * LT.tyc list
147 :     | UconList of (F.con * F.lexp) list
148 :     | Ulvar of LV.lvar
149 :     | UlvarList of LV.lvar list
150 :     | UtycsLvarPair of LT.tyc list * LV.lvar
151 :     | UtycsLvarPairList of (LT.tyc list * LV.lvar) list
152 :     | UlvarLtyPair of LV.lvar * LT.lty
153 :     | UlvarLtyPairList of (LV.lvar * LT.lty) list
154 :     | UtvarTkPair of LV.lvar * LT.tkind
155 :     | UtvarTkPairList of (LV.lvar * LT.tkind) list
156 :    
157 :     (**************************************************************************
158 :     * UTILITY FUNCTIONS *
159 :     **************************************************************************)
160 :    
161 :     structure R = ShareRead(type universal = universal)
162 :    
163 :     val ? = R.?
164 :     val % = R.%
165 :    
166 :     fun bool #"T" = %Ubool true
167 :     | bool #"F" = %Ubool false
168 :     | bool _ = raise Fail " | bool"
169 :    
170 :     fun list (alpha,alphaproj,alphalistproj,alphalistinj) =
171 :     let fun f #"N" = %alphalistinj nil
172 :     | f #"1" = alpha(fn a => %alphalistinj[alphaproj a])
173 :     | f #"2" = alpha(fn a => alpha(fn b =>
174 :     %alphalistinj[alphaproj a, alphaproj b]))
175 :     | f #"3" = alpha(fn a => alpha(fn b => alpha(fn c =>
176 :     %alphalistinj[alphaproj a, alphaproj b, alphaproj c])))
177 :     | f #"4" = alpha(fn a => alpha(fn b => alpha(fn c => alpha(fn d=>
178 :     %alphalistinj[alphaproj a, alphaproj b, alphaproj c,
179 :     alphaproj d]))))
180 :     | f #"5" = alpha(fn a => alpha(fn b => alpha(fn c =>
181 :     alpha(fn d=> alpha(fn e =>
182 :     %alphalistinj[alphaproj a, alphaproj b, alphaproj c,
183 :     alphaproj d, alphaproj e])))))
184 :     | f #"M" = alpha(fn a => alpha(fn b => alpha(fn c =>
185 :     alpha(fn d=> alpha(fn e => ?f(fn r =>
186 :     %alphalistinj(alphaproj a :: alphaproj b :: alphaproj c ::
187 :     alphaproj d :: alphaproj e ::
188 :     alphalistproj r)))))))
189 :     | f _ = raise Fail " | list"
190 :    
191 :     in f
192 :     end
193 :    
194 :     val boolList = list(?bool, fn Ubool t => t, fn UboolList t => t, UboolList)
195 :    
196 :     fun lvar #"x" = R.int (%Ulvar)
197 :     | lvar _ = raise Fail " | lvar"
198 :    
199 :     val lvarList = list (?lvar, fn Ulvar v => v, fn UlvarList l => l, UlvarList)
200 :    
201 :     fun numkind #"I" = R.int(fn i => %Unumkind(P.INT i))
202 :     | numkind #"U" = R.int(fn i => %Unumkind(P.UINT i))
203 :     | numkind #"F" = R.int(fn i => %Unumkind(P.FLOAT i))
204 :     | numkind _ = raise Fail " | numkind"
205 :    
206 :     fun arithop #"a" = %Uarithop P.+
207 :     | arithop #"b" = %Uarithop P.-
208 :     | arithop #"c" = %Uarithop P.*
209 :     | arithop #"d" = %Uarithop P./
210 :     | arithop #"e" = %Uarithop P.~
211 :     | arithop #"f" = %Uarithop P.ABS
212 :     | arithop #"g" = %Uarithop P.LSHIFT
213 :     | arithop #"h" = %Uarithop P.RSHIFT
214 :     | arithop #"i" = %Uarithop P.RSHIFTL
215 :     | arithop #"j" = %Uarithop P.ANDB
216 :     | arithop #"k" = %Uarithop P.ORB
217 :     | arithop #"l" = %Uarithop P.XORB
218 :     | arithop #"m" = %Uarithop P.NOTB
219 :     | arithop _ = raise Fail " | arithop"
220 :    
221 :     fun cmpop #"a" = %Ucmpop P.>
222 :     | cmpop #"b" = %Ucmpop P.>=
223 :     | cmpop #"c" = %Ucmpop P.<
224 :     | cmpop #"d" = %Ucmpop P.<=
225 :     | cmpop #"e" = %Ucmpop P.LEU
226 :     | cmpop #"f" = %Ucmpop P.LTU
227 :     | cmpop #"g" = %Ucmpop P.GEU
228 :     | cmpop #"h" = %Ucmpop P.GTU
229 :     | cmpop #"i" = %Ucmpop P.EQL
230 :     | cmpop #"j" = %Ucmpop P.NEQ
231 :     | cmpop _ = raise Fail " | cmpop"
232 :    
233 :     fun primop #"A" = ?arithop(fn Uarithop p =>
234 :     ?bool(fn Ubool v => ?numkind(fn Unumkind k =>
235 :     %Uprimop(P.ARITH{oper=p,overflow=v,kind=k}))))
236 :     | primop #"<" = ?numkind(fn Unumkind k => %Uprimop(P.INLLSHIFT k))
237 :     | primop #">" = ?numkind(fn Unumkind k => %Uprimop(P.INLRSHIFT k))
238 :     | primop #"L" = ?numkind(fn Unumkind k => %Uprimop(P.INLRSHIFTL k))
239 :     | primop #"C" = ?cmpop(fn Ucmpop p =>
240 :     ?numkind(fn Unumkind k =>
241 :     %Uprimop(P.CMP{oper=p,kind=k})))
242 :    
243 :     | primop #"G" =
244 :     R.int (fn from => R.int (fn to => %Uprimop(P.TEST(from,to))))
245 :     | primop #"H" =
246 :     R.int (fn from => R.int (fn to => %Uprimop(P.TESTU(from,to))))
247 :     | primop #"I" =
248 :     R.int (fn from => R.int (fn to => %Uprimop(P.TRUNC(from,to))))
249 :     | primop #"J" =
250 :     R.int (fn from => R.int (fn to => %Uprimop(P.EXTEND(from,to))))
251 :     | primop #"K" =
252 :     R.int (fn from => R.int (fn to => %Uprimop(P.COPY(from,to))))
253 :    
254 :     | primop #"R" = ?bool(fn Ubool f =>
255 :     ?numkind(fn Unumkind k =>
256 :     ?numkind(fn Unumkind t =>
257 :     %Uprimop(P.ROUND{floor=f,fromkind=k,tokind=t}))))
258 :     | primop #"F" = ?numkind(fn Unumkind k =>
259 :     ?numkind(fn Unumkind t =>
260 :     %Uprimop(P.REAL{fromkind=k,tokind=t})))
261 :     | primop #"S" = ?numkind(fn Unumkind k =>
262 :     ?bool(fn Ubool c =>
263 :     ?bool(fn Ubool i =>
264 :     %Uprimop(P.NUMSUBSCRIPT{kind=k,checked=c,immutable=i}))))
265 :     | primop #"U" = ?numkind(fn Unumkind k =>
266 :     ?bool(fn Ubool c =>
267 :     %Uprimop(P.NUMUPDATE{kind=k,checked=c})))
268 :     | primop #"M" = ?numkind(fn Unumkind k =>
269 :     %Uprimop(P.INL_MONOARRAY k))
270 :     | primop #"V" = ?numkind(fn Unumkind k =>
271 :     %Uprimop(P.INL_MONOVECTOR k))
272 :    
273 :     | primop #"X" = %Uprimop(P.MKETAG)
274 :     | primop #"Y" = %Uprimop(P.WRAP)
275 :     | primop #"Z" = %Uprimop(P.UNWRAP)
276 :    
277 :     | primop x = %Uprimop(
278 :     case x
279 :     of #"a" => P.SUBSCRIPT
280 :     | #"b" => P.SUBSCRIPTV
281 :     | #"c" => P.INLSUBSCRIPT
282 :     | #"d" => P.INLSUBSCRIPTV
283 :     | #"~" => P.INLMKARRAY
284 :     | #"e" => P.PTREQL
285 :     | #"f" => P.PTRNEQ
286 :     | #"g" => P.POLYEQL
287 :     | #"h" => P.POLYNEQ
288 :     | #"i" => P.BOXED
289 :     | #"j" => P.UNBOXED
290 :     | #"k" => P.LENGTH
291 :     | #"l" => P.OBJLENGTH
292 :     | #"m" => P.CAST
293 :     | #"n" => P.GETRUNVEC
294 :     | #"[" => P.MARKEXN
295 :     | #"o" => P.GETHDLR
296 :     | #"p" => P.SETHDLR
297 :     | #"q" => P.GETVAR
298 :     | #"r" => P.SETVAR
299 :     | #"s" => P.GETPSEUDO
300 :     | #"t" => P.SETPSEUDO
301 :     | #"u" => P.SETMARK
302 :     | #"v" => P.DISPOSE
303 :     | #"w" => P.MAKEREF
304 :     | #"x" => P.CALLCC
305 :     | #"y" => P.CAPTURE
306 :     | #"z" => P.THROW
307 :     | #"1" => P.DEREF
308 :     | #"2" => P.ASSIGN
309 :     | #"3" => P.UPDATE
310 :     | #"4" => P.INLUPDATE
311 :     | #"5" => P.BOXEDUPDATE
312 :     | #"6" => P.UNBOXEDUPDATE
313 :     | #"7" => P.GETTAG
314 :     | #"8" => P.MKSPECIAL
315 :     | #"9" => P.SETSPECIAL
316 :     | #"0" => P.GETSPECIAL
317 :     | #"!" => P.USELVAR
318 :     | #"@" => P.DEFLVAR
319 :     | #"#" => P.INLDIV
320 :     | #"$" => P.INLMOD
321 :     | #"%" => P.INLREM
322 :     | #"^" => P.INLMIN
323 :     | #"&" => P.INLMAX
324 :     | #"*" => P.INLABS
325 :     | #"(" => P.INLNOT
326 :     | #")" => P.INLCOMPOSE
327 :     | #"," => P.INLBEFORE
328 :     | #"." => P.INL_ARRAY
329 :     | #"/" => P.INL_VECTOR
330 :     | #":" => P.ISOLATE
331 :     | _ => raise Fail " | primop")
332 :    
333 :    
334 :     (*
335 :     * TODO: primtyc is still not implemented yet.
336 :     *)
337 :     fun primtyc x = raise Fail " primtyc unimplemented !"
338 :    
339 :     fun stripOpt (SOME x) = x
340 :     | stripOpt _ = raise Fail " | stripOpt"
341 :    
342 :     fun word t = R.string (t o stripOpt o Word.fromString)
343 :     fun word32 t = R.string (t o stripOpt o Word32.fromString)
344 :     fun int32 t = R.string (t o stripOpt o Int32.fromString)
345 :    
346 :     fun symbol c =
347 :     R.string(fn name => %Usymbol(
348 :     case c
349 :     of #"A" => S.varSymbol name
350 :     | #"B" => S.tycSymbol name
351 :     | #"C" => S.sigSymbol name
352 :     | #"D" => S.strSymbol name
353 :     | #"E" => S.fctSymbol name
354 :     | #"F" => S.fixSymbol name
355 :     | #"G" => S.labSymbol name
356 :     | #"H" => S.tyvSymbol name
357 :     | #"I" => S.fsigSymbol name
358 :     | _ => raise Fail " | symbol"))
359 :    
360 :     val symbolList =
361 :     list(?symbol,fn Usymbol t => t, fn UsymbolList t => t, UsymbolList)
362 :    
363 :     fun spath x = symbolList x
364 :     fun ipath x = symbolList x
365 :    
366 :     fun consig #"S" = R.int(fn i => R.int (fn j => %Uconsig(A.CSIG(i,j))))
367 :     | consig #"N" = %Uconsig (A.CNIL)
368 :     | consig _ = raise Fail " | consig"
369 :    
370 :     fun mkAccess (mkvar,stamp) =
371 :     let fun access #"L" = R.int(fn i => %Uaccess (mkvar i))
372 :     | access #"E" = R.w8vector(fn v =>
373 :     %Uaccess(A.EXTERN(PS.fromBytes v)))
374 :     | access #"P" = R.int(fn i =>
375 :     ?access(fn Uaccess a =>
376 :     %Uaccess(A.PATH(a,i))))
377 :     | access #"N" = %Uaccess A.NO_ACCESS
378 :     | access _ = raise Fail " | access"
379 :    
380 :     fun conrep #"U" = %Uconrep A.UNTAGGED
381 :     | conrep #"T" = R.int (fn i => %Uconrep(A.TAGGED i))
382 :     | conrep #"B" = %Uconrep(A.TRANSPARENT)
383 :     | conrep #"C" = R.int(fn i => %Uconrep(A.CONSTANT i))
384 :     | conrep #"R" = %Uconrep(A.REF)
385 :     | conrep #"V" = ?access(fn Uaccess a => %Uconrep(A.EXN a))
386 :     | conrep #"L" = %Uconrep(A.LISTCONS)
387 :     | conrep #"N" = %Uconrep(A.LISTNIL)
388 :     | conrep #"S" = %Uconrep(A.SUSP NONE)
389 :     | conrep #"X" = ?access(fn Uaccess a =>
390 :     ?access(fn Uaccess b =>
391 :     %Uconrep(A.SUSP (SOME (a,b)))))
392 :     | conrep _ = raise Fail " | conrep"
393 :    
394 :     fun lty #"A" = ?tyc (fn Utyc tc => %Ulty(LT.ltc_tyc tc))
395 :     | lty #"B" = ?ltyList (fn UltyList l => %Ulty(LT.ltc_str l))
396 :     | lty #"C" =
397 :     ?intltyList (fn UintltyList l => %Ulty(LT.ltc_pst l))
398 :     | lty #"D" =
399 :     ?ltyList (fn UltyList ts1 =>
400 :     ?ltyList (fn UltyList ts2 =>
401 :     %Ulty(LT.ltc_fct(ts1,ts2))))
402 :     | lty #"E" = ?tkindList (fn UtkindList ks =>
403 :     ?ltyList (fn UltyList ts =>
404 :     %Ulty(LT.ltc_poly(ks,ts))))
405 :     | lty _ = raise Fail " | lty"
406 :    
407 :     and ldTuple #"T" = ?lty (fn Ulty t =>
408 :     R.int (fn i => %UldTuple(t, i)))
409 :     | ldTuple _ = raise Fail " | ldTuple"
410 :    
411 :     and ldOption #"S" = ?ldTuple(fn UldTuple t => %UldOption (SOME t))
412 :     | ldOption #"N" = %UldOption NONE
413 :     | ldOption _ = raise Fail " | ltyOption"
414 :    
415 :     and ltyList x = list (?lty,fn Ulty t => t, fn UltyList t => t, UltyList) x
416 :    
417 :     and ltyListOption #"S" =
418 :     ?ltyList (fn UltyList ts => %UltyListOption (SOME ts))
419 :     | ltyListOption #"N" = %UltyListOption (NONE)
420 :     | ltyListOption _ = raise Fail " | ltyListOption"
421 :    
422 :     and intltyList x = list (?intltyTuple, fn UintltyTuple t => t,
423 :     fn UintltyList t => t, UintltyList) x
424 :    
425 :     and intltyTuple #"T" = R.int(fn i =>
426 :     ?lty(fn Ulty t => %UintltyTuple(i,t)))
427 :     | intltyTuple _ = raise Fail " | intltyTuple"
428 :    
429 :     and tyc #"A" = R.int (fn i => R.int (fn j =>
430 :     %Utyc (LT.tcc_var (DI.di_fromint i, j))))
431 :     | tyc #"B" = R.int (fn v =>
432 :     R.int (fn d =>
433 :     R.int (fn i =>
434 :     %Utyc (LT.tcc_nvar(v, DI.di_fromint d, i)))))
435 :     | tyc #"C" = R.int (fn k => %Utyc (LT.tcc_prim (PT.pt_fromint k)))
436 :     | tyc #"D" = ?tkindList (fn UtkindList ks =>
437 :     ?tyc (fn Utyc tc => %Utyc(LT.tcc_fn(ks, tc))))
438 :     | tyc #"E" = ?tyc (fn Utyc tc =>
439 :     ?tycList (fn UtycList ts => %Utyc(LT.tcc_app(tc, ts))))
440 :     | tyc #"F" = ?tycList (fn UtycList ts => %Utyc(LT.tcc_seq ts))
441 :     | tyc #"G" = ?tyc (fn Utyc tc => R.int (fn i =>
442 :     %Utyc(LT.tcc_proj(tc, i))))
443 :     | tyc #"H" = ?tycList (fn UtycList ts => %Utyc(LT.tcc_sum ts))
444 :     | tyc #"I" = R.int (fn n =>
445 :     ?tyc (fn Utyc tc =>
446 :     ?tycList (fn UtycList ts =>
447 :     R.int (fn i =>
448 :     %Utyc(LT.tcc_fix((n,tc,ts), i))))))
449 :     | tyc #"J" = ?tyc (fn Utyc tc => %Utyc(LT.tcc_abs tc))
450 :     | tyc #"K" = ?tyc (fn Utyc tc => %Utyc(LT.tcc_box tc))
451 :     | tyc #"L" = ?tycList (fn UtycList ts => %Utyc(LT.tcc_tuple ts))
452 :     | tyc #"M" = ?bool(fn Ubool b1 =>
453 :     ?bool(fn Ubool b2 =>
454 :     ?tycList (fn UtycList ts1 =>
455 :     ?tycList (fn UtycList ts2 =>
456 :     %Utyc(LT.tcc_arrow((b1,b2),ts1, ts2))))))
457 :     | tyc _ = raise Fail " | tyc"
458 :    
459 :     and tycList x = list (?tyc, fn Utyc t => t, fn UtycList t => t, UtycList) x
460 :    
461 :     and tkind #"A" = %Utkind (LT.tkc_mono)
462 :     | tkind #"B" = %Utkind (LT.tkc_box)
463 :     | tkind #"C" = ?tkindList (fn UtkindList ks =>
464 :     %Utkind (LT.tkc_seq ks))
465 :     | tkind #"D" = ?tkindList (fn UtkindList ks =>
466 :     ?tkind (fn Utkind k =>
467 :     %Utkind (LT.tkc_fun(ks, k))))
468 :     | tkind _ = raise Fail " | tkind"
469 :    
470 :     and tkindList x =
471 :     list (?tkind, fn Utkind t => t, fn UtkindList t => t, UtkindList) x
472 :    
473 :     and tkindtycTuple #"T" = ?tkind (fn Utkind k =>
474 :     ?tyc (fn Utyc t => %UtkindtycTuple(k, t)))
475 :     | tkindtycTuple _ = raise Fail " | tkindtycTuple"
476 :    
477 :     and tkindtycList x =
478 :     list (?tkindtycTuple, fn UtkindtycTuple t => t,
479 :     fn UtkindtycList t => t, UtkindtycList) x
480 :    
481 :     fun tycsLvarPair #"T" = ?tycList (fn UtycList ts =>
482 :     R.int (fn v => %UtycsLvarPair (ts, v)))
483 :     | tycsLvarPair _ = raise Fail " | tycsLvarPair"
484 :    
485 :     fun tycsLvarPairList x =
486 :     list (?tycsLvarPair, fn UtycsLvarPair t => t,
487 :     fn UtycsLvarPairList t => t, UtycsLvarPairList) x
488 :    
489 :     fun con #"." = ?dcon (fn Udcon (dc, ts) =>
490 :     ?lvar (fn Ulvar v =>
491 :     ?lexp (fn Ulexp e =>
492 :     %Ucon (F.DATAcon (dc, ts, v), e))))
493 :     | con #"," = R.int (fn i =>
494 :     ?lexp (fn Ulexp e => %Ucon (F.INTcon i, e)))
495 :     | con #"=" = int32 (fn i32 =>
496 :     ?lexp (fn Ulexp e =>
497 :     %Ucon (F.INT32con i32, e)))
498 :     | con #"?" = word (fn w =>
499 :     ?lexp (fn Ulexp e =>
500 :     %Ucon (F.WORDcon w, e)))
501 :     | con #">" = word32 (fn w32 =>
502 :     ?lexp (fn Ulexp e =>
503 :     %Ucon (F.WORD32con w32, e)))
504 :     | con #"<" = R.string (fn s =>
505 :     ?lexp (fn Ulexp e =>
506 :     %Ucon (F.REALcon s, e)))
507 :     | con #"'" = R.string (fn s =>
508 :     ?lexp (fn Ulexp e =>
509 :     %Ucon (F.STRINGcon s, e)))
510 :     | con #";" = R.int (fn i =>
511 :     ?lexp (fn Ulexp e => %Ucon (F.VLENcon i, e)))
512 :     | con _ = raise Fail " | con"
513 :    
514 :     and conList x =
515 :     list (?con, fn Ucon c => c, fn UconList l => l, UconList) x
516 :    
517 :     and dcon #"^" = ?symbol(fn Usymbol s =>
518 :     ?conrep (fn Uconrep cr =>
519 :     ?lty (fn Ulty t =>
520 :     ?tycList (fn UtycList ts =>
521 :     %Udcon((s, cr, t), ts)))))
522 :     | dcon _ = raise Fail " | dcon"
523 :    
524 :     and dict #"%" = R.int (fn v =>
525 :     ?tycsLvarPairList (fn UtycsLvarPairList tbls =>
526 :     %Udict {default=v, table=tbls}))
527 :     | dict _ = raise Fail " | dict"
528 :    
529 :     and value #"a" = R.int (fn v => %Uvalue (F.VAR v))
530 :     | value #"b" = R.int (fn i => %Uvalue (F.INT i))
531 :     | value #"c" = int32 (fn i32 => %Uvalue (F.INT32 i32))
532 :     | value #"d" = word (fn w => %Uvalue (F.WORD w))
533 :     | value #"e" = word32 (fn w32 => %Uvalue (F.WORD32 w32))
534 :     | value #"f" = R.string (fn s => %Uvalue (F.REAL s))
535 :     | value #"g" = R.string (fn s => %Uvalue (F.STRING s))
536 :     | value _ = raise Fail " | value"
537 :    
538 :     and fprim #"h" = ?primop (fn Uprimop p =>
539 :     ?lty (fn Ulty t =>
540 :     ?tycList (fn UtycList ts =>
541 :     %Ufprim (NONE, p, t, ts))))
542 :    
543 :     | fprim #"i" = ?dict (fn Udict nd =>
544 :     ?primop (fn Uprimop p =>
545 :     ?lty (fn Ulty t =>
546 :     ?tycList (fn UtycList ts =>
547 :     %Ufprim (SOME nd, p, t, ts)))))
548 :    
549 :     | fprim _ = raise Fail " | fprim"
550 :    
551 :     and valueList x =
552 :     list (?value, fn Uvalue v => v, fn UvalueList l => l, UvalueList) x
553 :    
554 :     and lexp #"j" = ?valueList (fn UvalueList vs => %Ulexp (F.RET vs))
555 :     | lexp #"k" = ?lvarList (fn UlvarList vs =>
556 :     ?lexp (fn Ulexp e1 =>
557 :     ?lexp (fn Ulexp e2 => %Ulexp (F.LET(vs, e1, e2)))))
558 :     | lexp #"l" = ?fundecList (fn UfundecList fdecs =>
559 :     ?lexp (fn Ulexp e =>
560 :     %Ulexp (F.FIX(fdecs, e))))
561 :     | lexp #"m" = ?value (fn Uvalue u =>
562 :     ?valueList (fn UvalueList vs =>
563 :     %Ulexp (F.APP (u, vs))))
564 :     | lexp #"n" = ?tfundec (fn Utfundec tfdec =>
565 :     ?lexp (fn Ulexp e =>
566 :     %Ulexp (F.TFN (tfdec, e))))
567 :     | lexp #"o" = ?value (fn Uvalue u =>
568 :     ?tycList (fn UtycList ts =>
569 :     %Ulexp (F.TAPP (u, ts))))
570 :     | lexp #"p" = ?value (fn Uvalue v =>
571 :     ?consig (fn Uconsig crl =>
572 :     ?conList (fn UconList cel =>
573 :     ?lexpOption (fn UlexpOption eo =>
574 :     %Ulexp (F.SWITCH (v, crl, cel, eo))))))
575 :     | lexp #"q" = ?dcon (fn Udcon (c, ts) =>
576 :     ?value (fn Uvalue u =>
577 :     ?lvar (fn Ulvar v =>
578 :     ?lexp (fn Ulexp e =>
579 :     %Ulexp (F.CON (c, ts, u, v,e ))))))
580 :     | lexp #"r" = ?rkind (fn Urkind rk =>
581 :     ?valueList (fn UvalueList vl =>
582 :     ?lvar (fn Ulvar v =>
583 :     ?lexp (fn Ulexp e =>
584 :     %Ulexp (F.RECORD(rk, vl, v, e))))))
585 :     | lexp #"s" = ?value (fn Uvalue u =>
586 :     R.int (fn i =>
587 :     ?lvar (fn Ulvar v =>
588 :     ?lexp (fn Ulexp e =>
589 :     %Ulexp (F.SELECT(u, i, v, e))))))
590 :     | lexp #"t" = ?value (fn Uvalue v =>
591 :     ?ltyList (fn UltyList ts =>
592 :     %Ulexp (F.RAISE (v, ts))))
593 :     | lexp #"u" = ?lexp (fn Ulexp e =>
594 :     ?value (fn Uvalue u =>
595 :     %Ulexp (F.HANDLE (e, u))))
596 :     | lexp #"v" = ?fprim (fn Ufprim p =>
597 :     ?valueList (fn UvalueList vs =>
598 :     ?lexp (fn Ulexp e1 =>
599 :     ?lexp (fn Ulexp e2 =>
600 :     %Ulexp (F.BRANCH(p, vs, e1, e2))))))
601 :     | lexp #"w" = ?fprim (fn Ufprim p =>
602 :     ?valueList (fn UvalueList vs =>
603 :     ?lvar (fn Ulvar v =>
604 :     ?lexp (fn Ulexp e =>
605 :     %Ulexp (F.PRIMOP(p, vs, v, e))))))
606 :     | lexp _ = raise Fail " | lexp"
607 :    
608 :    
609 :     and lexpList x =
610 :     list (?lexp, fn Ulexp e => e, fn UlexpList l => l, UlexpList) x
611 :    
612 :     and lexpOption #"S" = ?lexp (fn Ulexp e => %UlexpOption (SOME e))
613 :     | lexpOption #"N" = %UlexpOption NONE
614 :     | lexpOption _ = raise Fail " | lexpOption"
615 :    
616 :     and fundec #"0" = ?fkind (fn Ufkind fk =>
617 :     ?lvar (fn Ulvar v =>
618 :     ?lvarLtyPairList (fn UlvarLtyPairList vts =>
619 :     ?lexp (fn Ulexp e =>
620 :     %Ufundec (fk, v, vts, e)))))
621 :     | fundec _ = raise Fail " | fundec"
622 :    
623 :     and fundecOption #"S" = ?fundec (fn Ufundec f => %UfundecOption (SOME f))
624 :     | fundecOption #"N" = %UfundecOption NONE
625 :     | fundecOption _ = raise Fail " | fundecOption"
626 :    
627 :     and fundecList x =
628 :     list (?fundec, fn Ufundec x => x, fn UfundecList l => l,
629 :     UfundecList) x
630 :    
631 :     and lvarLtyPair #"T" = ?lvar (fn Ulvar v =>
632 :     ?lty (fn Ulty t => %UlvarLtyPair (v, t)))
633 :     | lvarLtyPair _ = raise Fail " | lvarLtyPair"
634 :    
635 :     and lvarLtyPairList x =
636 :     list (?lvarLtyPair, fn UlvarLtyPair x => x, fn UlvarLtyPairList l => l,
637 :     UlvarLtyPairList) x
638 :    
639 :     and tvarTkPair #"T" = ?lvar (fn Ulvar tv =>
640 :     ?tkind (fn Utkind tk => %UtvarTkPair (tv, tk)))
641 :     | tvarTkPair _ = raise Fail " | tvarTkPair"
642 :    
643 :     and tvarTkPairList x =
644 :     list (?tvarTkPair, fn UtvarTkPair x => x, fn UtvarTkPairList l => l,
645 :     UtvarTkPairList) x
646 :    
647 :     and tfundec #"0" = ?lvar (fn Ulvar v =>
648 :     ?tvarTkPairList (fn UtvarTkPairList tvks =>
649 :     ?lexp (fn Ulexp e =>
650 :     %Utfundec (v, tvks, e))))
651 :     | tfundec _ = raise Fail " | tfundec"
652 :    
653 :     and fkind #"2" = %Ufkind (F.FK_FCT)
654 :     | fkind #"3" = ?ltyListOption (fn UltyListOption isrec =>
655 :     ?bool (fn Ubool b1 =>
656 :     ?bool (fn Ubool b2 =>
657 :     ?bool (fn Ubool known =>
658 :     ?bool (fn Ubool inline =>
659 :     %Ufkind (F.FK_FUN{isrec=isrec, fixed=(b1, b2),
660 :     known=known, inline=inline}))))))
661 :     | fkind _ = raise Fail " | fkind"
662 :    
663 :     and rkind #"4" = ?tyc (fn Utyc tc => %Urkind (F.RK_VECTOR tc))
664 :     | rkind #"5" = %Urkind (F.RK_STRUCT)
665 :     | rkind #"6" = %Urkind (FlintUtil.rk_tuple)
666 :     | rkind _ = raise Fail " | rkind"
667 :    
668 :     fun ldOptionList x =
669 :     list (?ldOption, fn UldOption to => to,
670 :     fn UldOptionList tol => tol, UldOptionList) x
671 :    
672 :     in {access=access, lexp=lexp, conrep=conrep,
673 :     tkind=tkind, fundecOption=fundecOption, ldOptionList=ldOptionList}
674 :     end
675 :    
676 :     fun mkStamp globalPid =
677 :     let fun stamp #"L" =
678 :     R.int(fn j =>
679 :     %Ustamp(Stamps.STAMP{scope=Stamps.GLOBAL globalPid, count=j}))
680 :     | stamp #"G" =
681 :     R.w8vector(fn s =>
682 :     R.int(fn j =>
683 :     %Ustamp(Stamps.STAMP{scope=Stamps.GLOBAL(PS.fromBytes s),
684 :     count=j})))
685 :     | stamp #"S" =
686 :     R.string(fn s => R.int(fn j =>
687 :     %Ustamp(Stamps.STAMP{scope=Stamps.SPECIAL s, count=j})))
688 :    
689 :     | stamp _ = raise Fail " | stamp"
690 :     in stamp
691 :     end
692 :    
693 :     fun unpickleFLINT({hash: PS.persstamp, pickle: Word8Vector.vector}) =
694 :     let val stamp = mkStamp hash (* ZHONG? *)
695 :     val {fundecOption, ...} = mkAccess(A.LVAR,stamp)
696 :     val UfundecOption result = R.root(pickle, fundecOption)
697 :     in result
698 :     end
699 :    
700 :     (**************************************************************************
701 :     * UNPICKLING AN ENVIRONMENT *
702 :     **************************************************************************)
703 :    
704 :     fun unpickleEnv (context0, pickle) =
705 :     let val {hash=globalPid, pickle=p0: Word8Vector.vector} = pickle
706 :    
707 :     fun import i = A.PATH (A.EXTERN globalPid, i)
708 :     val stamp = mkStamp globalPid
709 :     val {access,lexp,conrep,tkind,ldOptionList,fundecOption} =
710 :     mkAccess(import,stamp)
711 :    
712 :    
713 :     val entVar = stamp
714 :     val entPath = list(?entVar, fn Ustamp t => t,
715 :     fn UentPath t => t, UentPath)
716 :    
717 :     fun modId #"B" = ?stamp(fn Ustamp a => ?stamp(fn Ustamp b =>
718 :     %UmodId(MI.STRid{rlzn=a,sign=b})))
719 :     | modId #"C" = ?stamp(fn Ustamp s => %UmodId(MI.SIGid s))
720 :     | modId #"E" = ?stamp(fn Ustamp a => ?modId(fn UmodId b =>
721 :     %UmodId(MI.FCTid{rlzn=a,sign=b})))
722 :     | modId #"F" = ?stamp(fn Ustamp a => ?stamp(fn Ustamp b =>
723 :     %UmodId(MI.FSIGid{paramsig=a,bodysig=b})))
724 :     | modId #"G" = ?stamp(fn Ustamp s =>
725 :     %UmodId(MI.TYCid s))
726 :     | modId #"V" = ?stamp(fn Ustamp s => %UmodId(MI.EENVid s))
727 :    
728 :     | modId _ = raise Fail " | modId"
729 :    
730 :     val label = symbol
731 :    
732 :     fun eqprop c =
733 :     %Ueqprop(case c
734 :     of #"Y" => T.YES
735 :     | #"N" => T.NO
736 :     | #"I" => T.IND
737 :     | #"O" => T.OBJ
738 :     | #"D" => T.DATA
739 :     | #"A" => T.ABS
740 :     | #"U" => T.UNDEF
741 :     | _ => raise Fail " | eqprop")
742 :    
743 :    
744 :     fun datacon #"D" =
745 :     ?symbol(fn Usymbol n =>
746 :     ?bool(fn Ubool c =>
747 :     ?ty(fn Uty t =>
748 :     ?conrep(fn Uconrep r =>
749 :     ?consig(fn Uconsig s =>
750 :     %Udatacon(T.DATACON{name=n,const=c,typ=t,
751 :     rep=r,sign=s}))))))
752 :     | datacon _ = raise Fail " | datacon"
753 :    
754 :    
755 :     and tyOption #"S" = ?ty(fn Uty t => %UtyOption (SOME t))
756 :     | tyOption #"N" = %UtyOption NONE
757 :     | tyOption _ = raise Fail " | tyOption"
758 :    
759 :     and tyList x = list(?ty, fn Uty t => t, fn UtyList t => t, UtyList) x
760 :    
761 :     and tyckind #"P" =
762 :     R.int(fn k => %Utyckind(T.PRIMITIVE (PT.pt_fromint k)))
763 :     | tyckind #"D" =
764 :     R.int(fn i =>
765 :     ?entVarOption(fn UentVarOption root =>
766 :     ?dtypeInfo (fn UdtypeInfo (ss, family, freetycs) =>
767 :     %Utyckind(T.DATATYPE {index=i,root=root,family=family,
768 :     stamps=ss, freetycs=freetycs}))))
769 :     | tyckind #"A" =
770 :     ?tycon (fn Utycon tc => %Utyckind(T.ABSTRACT tc))
771 :     | tyckind #"S" = raise Fail " | tyckind-tycpath"
772 :     | tyckind #"F" = %Utyckind T.FORMAL
773 :     | tyckind #"T" = %Utyckind T.TEMP
774 :     | tyckind _ = raise Fail " | tyckind"
775 :    
776 :     and dtypeInfo #"Z" =
777 :     ?stampList (fn UentPath ss =>
778 :     ?dtFamily (fn UdtFamily ff =>
779 :     ?tyconList (fn UtyconList tt =>
780 :     %UdtypeInfo(Vector.fromList ss, ff, tt))))
781 :     | dtypeInfo _ = raise Fail " | dtypeInfo"
782 :    
783 :     and dtFamily #"U" =
784 :     ?stamp (fn Ustamp s =>
785 :     ?dtmemberList (fn UdtmemberList ds =>
786 :     %UdtFamily ({mkey=s, members=Vector.fromList ds,
787 :     lambdatyc = ref NONE})))
788 :     | dtFamily _ = raise Fail " | dtFamily"
789 :    
790 :     and stampList x = entPath x
791 :    
792 :     and dtmemberList x =
793 :     list(?dtmember, fn Udtmember t => t,
794 :     fn UdtmemberList t => t, UdtmemberList) x
795 :    
796 :     and dtmember #"T" =
797 :     ?symbol(fn Usymbol n =>
798 :     ?nameRepDomainList(fn UnameRepDomainList l =>
799 :     R.int(fn i =>
800 :     ?eqprop(fn Ueqprop e =>
801 :     ?consig(fn Uconsig sn =>
802 :     %Udtmember{tycname=n,dcons=l,arity=i,
803 :     eq=ref e,sign=sn})))))
804 :     | dtmember _ = raise Fail " | dtmember"
805 :    
806 :     and nameRepDomainList x =
807 :     list(?nameRepDomain,fn UnameRepDomain t => t,
808 :     fn UnameRepDomainList t => t, UnameRepDomainList) x
809 :    
810 :     and nameRepDomain #"N" =
811 :     ?symbol(fn Usymbol n =>
812 :     ?conrep(fn Uconrep r =>
813 :     ?tyOption(fn UtyOption t =>
814 :     %UnameRepDomain{name=n,rep=r,domain=t})))
815 :     | nameRepDomain _ = raise Fail " | nameRepDomain"
816 :    
817 :     and tycon #"X" = ?modId(fn UmodId id =>
818 :     case SCStaticEnv.lookTYC context0 id
819 :     of SOME t => %Utycon t)
820 :     | tycon #"G" = ?stamp(fn Ustamp s =>
821 :     R.int(fn a =>
822 :     ?eqprop(fn Ueqprop e =>
823 :     ?tyckind(fn Utyckind k =>
824 :     ?ipath(fn UsymbolList p =>
825 :     %Utycon(T.GENtyc{stamp=s,arity=a,eq=ref e,kind=k,
826 :     path=IP.IPATH p}))))))
827 :     | tycon #"D" = ?stamp(fn Ustamp x =>
828 :     R.int(fn r =>
829 :     ?ty(fn Uty b =>
830 :     ?boolList(fn UboolList s =>
831 :     ?ipath(fn UsymbolList p =>
832 :     %Utycon(T.DEFtyc{stamp=x,
833 :     tyfun=T.TYFUN{arity=r,body=b},
834 :     strict=s,path=IP.IPATH p}))))))
835 :    
836 :     | tycon #"P" = R.int(fn a =>
837 :     ?ipath(fn UsymbolList p =>
838 :     ?entPath(fn UentPath e =>
839 :     %Utycon(T.PATHtyc{arity=a, entPath=e,
840 :     path=IP.IPATH p}))))
841 :    
842 :     | tycon #"R" = ?symbolList(fn UsymbolList l =>
843 :     %Utycon(T.RECORDtyc l))
844 :     | tycon #"C" = R.int(fn i => %Utycon(T.RECtyc i))
845 :     | tycon #"H" = R.int(fn i => %Utycon(T.FREEtyc i))
846 :     | tycon #"E" = %Utycon(T.ERRORtyc)
847 :     | tycon _ = raise Fail " | tycon"
848 :    
849 :     and tyconList x = list(?tycon, fn Utycon t => t,
850 :     fn UtyconList t => t, UtyconList) x
851 :    
852 :    
853 :     and symbolOption #"S" = ?symbol(fn Usymbol s =>
854 :     %UsymbolOption(SOME s))
855 :     | symbolOption #"N" = %UsymbolOption NONE
856 :     | symbolOption _ = raise Fail " | symbolOption"
857 :    
858 :     and intOption #"S" = R.int (fn s => %UintOption(SOME s))
859 :     | intOption #"N" = %UintOption NONE
860 :     | intOption _ = raise Fail " | intOption"
861 :    
862 :     and spathList x =
863 :     list(?spath,fn UsymbolList t => SP.SPATH t, fn UspathList t => t,
864 :     UspathList) x
865 :    
866 :     and spathListList x =
867 :     list(?spathList,fn UspathList l => l, fn UspathListList t => t,
868 :     UspathListList) x
869 :    
870 :     and ty #"C" = ?tycon(fn Utycon c => ?tyList(fn UtyList l =>
871 :     %Uty(T.CONty(c,l))))
872 :     | ty #"N" = ?tycon(fn Utycon c => %Uty(T.CONty(c,nil)))
873 :     | ty #"I" = R.int(fn i => %Uty(T.IBOUND i))
874 :     | ty #"W" = %Uty T.WILDCARDty
875 :     | ty #"P" = ?boolList(fn UboolList s =>
876 :     R.int(fn r =>
877 :     ?ty(fn Uty b =>
878 :     %Uty(T.POLYty{sign=s, tyfun=T.TYFUN{arity=r,body=b}}))))
879 :     | ty #"U" = %Uty(T.UNDEFty)
880 :     | ty _ = raise Fail " | ty"
881 :    
882 :     and inl_info #"P" = ?primop(fn Uprimop p =>
883 :     ?tyOption(fn UtyOption t =>
884 :     %Uinl_info(II.INL_PRIM(p, t))))
885 :    
886 :     | inl_info #"S" = ?inl_infoList(fn Uinl_infoList sl =>
887 :     %Uinl_info(II.INL_STR sl))
888 :    
889 :     | inl_info #"N" = %Uinl_info(II.INL_NO)
890 :    
891 :     | inl_info #"L" = raise Fail "INL_LEXP not implemented"
892 :    
893 :     | inl_info #"A" = ?access(fn Uaccess a =>
894 :     ?tyOption(fn UtyOption t =>
895 :     %Uinl_info(II.INL_PATH(a, t))))
896 :    
897 :    
898 :     and inl_infoList s = list(?inl_info, (fn Uinl_info x => x),
899 :     (fn Uinl_infoList x => x), Uinl_infoList) s
900 :    
901 :     and var #"V" = ?access(fn Uaccess a =>
902 :     ?inl_info(fn Uinl_info z =>
903 :     ?spath(fn UsymbolList p =>
904 :     ?ty(fn Uty t =>
905 :     %Uvar(V.VALvar{access=a, info=z,
906 :     path=SP.SPATH p, typ=ref t})))))
907 :    
908 :     | var #"O" = ?symbol(fn Usymbol n =>
909 :     ?overldList(fn UoverldList p =>
910 :     R.int(fn r=>
911 :     ?ty(fn Uty b =>
912 :     %Uvar(V.OVLDvar{name=n,options=ref p,
913 :     scheme=T.TYFUN{arity=r,body=b}})))))
914 :    
915 :     | var #"E" = %Uvar(V.ERRORvar)
916 :     | var _ = raise Fail " | var"
917 :    
918 :     and overld #"O" = ?ty(fn Uty i => ?var(fn Uvar v =>
919 :     %Uoverld{indicator=i,variant=v}))
920 :    
921 :     and overldList x = list(?overld, fn Uoverld t => t,
922 :     fn UoverldList t => t, UoverldList) x
923 :    
924 :    
925 :     and strDef #"C" =
926 :     ?Structure(fn UStructure s => %UstrDef(M.CONSTstrDef s))
927 :     | strDef #"V" =
928 :     ?Signature(fn USignature s =>
929 :     ?entPath(fn UentPath a =>
930 :     %UstrDef(M.VARstrDef(s,a))))
931 :     | strDef _ = raise Fail " | strDef"
932 :    
933 :     and strDefIntTuple #"T" =
934 :     ?strDef(fn UstrDef s =>
935 :     R.int(fn i =>
936 :     %UstrDefIntTuple(s,i)))
937 :     | strDefIntTuple _ = raise Fail " | strDefIntTuple"
938 :    
939 :     and strDefIntOption #"S" =
940 :     ?strDefIntTuple(fn UstrDefIntTuple d =>
941 :     %UstrDefIntOption(SOME d))
942 :     | strDefIntOption #"N" = %UstrDefIntOption NONE
943 :     | strDefIntOption _ = raise Fail " | strDefIntOption"
944 :    
945 :     and elements x =
946 :     list (?element,fn Uelement t => t, fn Uelements t => t, Uelements) x
947 :    
948 :     and element #"T" =
949 :     ?symbol(fn Usymbol s =>
950 :     ?spec(fn Uspec c =>
951 :     %Uelement(s,c)))
952 :     | element _ = raise Fail " | element"
953 :    
954 :    
955 :     and boundepsElem #"T" = ?entPath(fn UentPath a =>
956 :     ?tkind(fn Utkind tk => %UboundepsElem(a, tk)))
957 :     | boundepsElem _ = raise Fail " | boundepsElem"
958 :    
959 :     and boundepsList x =
960 :     list(?boundepsElem, fn UboundepsElem t => t,
961 :     fn UboundepsList t => t, UboundepsList) x
962 :    
963 :     and boundepsOption #"S" = ?boundepsList(fn UboundepsList x =>
964 :     %UboundepsOption(SOME x))
965 :     | boundepsOption #"N" = %UboundepsOption NONE
966 :     | boundepsOption _ = raise Fail " | boundepsOption"
967 :    
968 :     and Signature #"X" = ?modId(fn UmodId id =>
969 :     case SCStaticEnv.lookSIG context0 id
970 :     of SOME t => %USignature t)
971 :    
972 :     | Signature #"S" =
973 :     ?symbolOption(fn UsymbolOption k =>
974 :     ?bool(fn Ubool c =>
975 :     ?bool(fn Ubool f =>
976 :     ?stamp(fn Ustamp m =>
977 :     ?symbolList(fn UsymbolList l =>
978 :     ?elements(fn Uelements e =>
979 :     ?boundepsOption(fn UboundepsOption b =>
980 :     ?spathListList(fn UspathListList t =>
981 :     ?spathListList(fn UspathListList s =>
982 :     %USignature(M.SIG{name=k,closed=c,fctflag=f,
983 :     stamp=m, symbols=l,
984 :     elements=e, boundeps=ref b,
985 :     lambdaty=ref NONE,
986 :     typsharing=t,strsharing=s}))))))))))
987 :     | Signature #"E" = %USignature M.ERRORsig
988 :     | Signature _ = raise Fail " | Signature"
989 :    
990 :     and fctSig #"X" = ?modId(fn UmodId id =>
991 :     case SCStaticEnv.lookFSIG context0 id
992 :     of SOME t => %UfctSig t)
993 :     | fctSig #"F" =
994 :     ?symbolOption(fn UsymbolOption k =>
995 :     ?Signature(fn USignature p =>
996 :     ?entVar(fn Ustamp q =>
997 :     ?symbolOption(fn UsymbolOption s =>
998 :     ?Signature(fn USignature b =>
999 :     %UfctSig(M.FSIG{kind=k,paramsig=p,paramvar=q,paramsym=s,
1000 :     bodysig=b}))))))
1001 :     | fctSig #"E" = %UfctSig M.ERRORfsig
1002 :     | fctSig _ = raise Fail " | fctSig"
1003 :    
1004 :     and spec #"T" = ?tycon(fn Utycon t =>
1005 :     ?entVar(fn Ustamp v =>
1006 :     R.int(fn s =>
1007 :     %Uspec(M.TYCspec{spec=t, entVar=v, scope=s}))))
1008 :     | spec #"S" = ?Signature (fn USignature s =>
1009 :     R.int (fn d =>
1010 :     ?strDefIntOption(fn UstrDefIntOption e =>
1011 :     ?entVar (fn Ustamp v =>
1012 :     %Uspec(M.STRspec{sign=s, slot=d, def=e, entVar=v})))))
1013 :     | spec #"F" = ?fctSig (fn UfctSig s =>
1014 :     R.int (fn d =>
1015 :     ?entVar (fn Ustamp v =>
1016 :     %Uspec(M.FCTspec{sign=s, slot=d, entVar=v}))))
1017 :     | spec #"P" = ?ty (fn Uty t => R.int(fn d =>
1018 :     %Uspec(M.VALspec{spec=t,slot=d})))
1019 :     | spec #"Q" = ?datacon (fn Udatacon c =>
1020 :     ?intOption (fn UintOption d =>
1021 :     %Uspec(M.CONspec{spec=c,slot=d})))
1022 :     | spec _ = raise Fail " | spec"
1023 :    
1024 :     and entity #"L" = ?tycEntity(fn Utycon t => %Uentity(M.TYCent t))
1025 :     | entity #"S" = ?strEntity(fn UstrEntity t => %Uentity(M.STRent t))
1026 :     | entity #"F" = ?fctEntity(fn UfctEntity t => %Uentity(M.FCTent t))
1027 :     | entity #"E" = %Uentity(M.ERRORent)
1028 :     | entity _ = raise Fail " | entity"
1029 :    
1030 :     and fctClosure #"F" =
1031 :     ?entVar(fn Ustamp p =>
1032 :     ?strExp(fn UstrExp s =>
1033 :     ?entityEnv(fn UentityEnv e =>
1034 :     %UfctClosure(M.CLOSURE{param=p,body=s,env=e}))))
1035 :     | fctClosure _ = raise Fail " | fctClosure"
1036 :    
1037 :     and Structure #"X" = ?modId(fn UmodId id =>
1038 :     ?access(fn Uaccess a =>
1039 :     case SCStaticEnv.lookSTR context0 id
1040 :     of SOME(M.STR{sign=s,rlzn=r,access=_,info=z})
1041 :     => %UStructure(M.STR{sign=s,rlzn=r,
1042 :     access=a,info=z})
1043 :     | NONE =>
1044 :     raise Fail "missing external Structure"))
1045 :     | Structure #"S" =
1046 :     ?Signature (fn USignature s =>
1047 :     ?strEntity (fn UstrEntity r =>
1048 :     ?access (fn Uaccess a =>
1049 :     ?inl_info (fn Uinl_info z =>
1050 :     %UStructure(M.STR{sign=s, rlzn=r, access=a,
1051 :     info=z})))))
1052 :    
1053 :     | Structure #"G" = ?Signature (fn USignature s =>
1054 :     ?entPath (fn UentPath a =>
1055 :     %UStructure(M.STRSIG{sign=s,entPath=a})))
1056 :     | Structure #"E" = %UStructure M.ERRORstr
1057 :    
1058 :     | Structure _ = raise Fail " | Structure"
1059 :    
1060 :     and Functor #"X" = ?modId(fn UmodId id =>
1061 :     ?access(fn Uaccess a =>
1062 :     case SCStaticEnv.lookFCT context0 id
1063 :     of SOME(M.FCT{sign=s,rlzn=r,access=_,info=z}) =>
1064 :     %UFunctor(M.FCT{sign=s,rlzn=r,access=a,info=z})
1065 :     | NONE =>
1066 :     raise Fail "missing external Functor"))
1067 :     | Functor #"F" =
1068 :     ?fctSig(fn UfctSig s =>
1069 :     ?fctEntity(fn UfctEntity r =>
1070 :     ?access(fn Uaccess a =>
1071 :     ?inl_info(fn Uinl_info z =>
1072 :     %UFunctor(M.FCT{sign=s, rlzn=r, access=a,
1073 :     info=z})))))
1074 :     | Functor #"E" = %UFunctor M.ERRORfct
1075 :    
1076 :     | Functor _ = raise Fail " | Functor"
1077 :    
1078 :     and stampExp #"C" = ?stamp(fn Ustamp s => %UstampExp(M.CONST s))
1079 :     | stampExp #"G" = ?strExp(fn UstrExp s => %UstampExp(M.GETSTAMP s))
1080 :     | stampExp #"N" = %UstampExp M.NEW
1081 :     | stampExp _ = raise Fail " | stampExp"
1082 :    
1083 :     and entVarOption #"S" = ?entVar(fn Ustamp x =>
1084 :     %UentVarOption(SOME x))
1085 :     | entVarOption #"N" = %UentVarOption NONE
1086 :     | entVarOption _ = raise Fail " | entVarOption"
1087 :    
1088 :     and tycExp #"C" = ?tycon(fn Utycon t => %UtycExp(M.CONSTtyc t))
1089 :     | tycExp #"D" = ?tycon(fn Utycon t => %UtycExp(M.FORMtyc t))
1090 :     | tycExp #"V" = ?entPath(fn UentPath s => %UtycExp(M.VARtyc s))
1091 :     | tycExp _ = raise Fail " | tycExp"
1092 :    
1093 :     and strExp #"V" = ?entPath(fn UentPath s => %UstrExp(M.VARstr s))
1094 :     | strExp #"C" = ?strEntity(fn UstrEntity s => %UstrExp(M.CONSTstr s))
1095 :     | strExp #"S" = ?stampExp(fn UstampExp s =>
1096 :     ?entityDec(fn UentityDec e=>
1097 :     %UstrExp(M.STRUCTURE{stamp=s,entDec=e})))
1098 :     | strExp #"A" = ?fctExp(fn UfctExp f =>
1099 :     ?strExp(fn UstrExp s =>
1100 :     %UstrExp(M.APPLY(f,s))))
1101 :     | strExp #"L" = ?entityDec(fn UentityDec e =>
1102 :     ?strExp(fn UstrExp s =>
1103 :     %UstrExp(M.LETstr(e,s))))
1104 :     | strExp #"B" = ?Signature(fn USignature s =>
1105 :     ?strExp(fn UstrExp e =>
1106 :     %UstrExp(M.ABSstr(s,e))))
1107 :     | strExp #"R" = ?entVar(fn Ustamp s =>
1108 :     ?strExp(fn UstrExp e1 =>
1109 :     ?strExp(fn UstrExp e2 =>
1110 :     %UstrExp(M.CONSTRAINstr{boundvar=s,raw=e1,coercion=e2}))))
1111 :     | strExp #"F" = ?fctSig(fn UfctSig x =>
1112 :     %UstrExp(M.FORMstr x))
1113 :     | strExp _ = raise Fail " | strExp"
1114 :    
1115 :     and fctExp #"V" = ?entPath(fn UentPath s => %UfctExp(M.VARfct s))
1116 :     | fctExp #"C" = ?fctEntity(fn UfctEntity s => %UfctExp(M.CONSTfct s))
1117 :     | fctExp #"L" = ?entVar(fn Ustamp p =>
1118 :     ?strExp(fn UstrExp b =>
1119 :     %UfctExp(M.LAMBDA{param=p, body=b})))
1120 :     | fctExp #"P" = ?entVar(fn Ustamp p =>
1121 :     ?strExp(fn UstrExp b =>
1122 :     ?fctSig(fn UfctSig x =>
1123 :     %UfctExp(M.LAMBDA_TP{param=p, body=b,
1124 :     sign=x}))))
1125 :     | fctExp #"T" = ?entityDec(fn UentityDec e =>
1126 :     ?fctExp (fn UfctExp f =>
1127 :     %UfctExp(M.LETfct(e,f))))
1128 :     | fctExp _ = raise Fail " | fctExp"
1129 :    
1130 :     and entityExp #"T" = ?tycExp(fn UtycExp t => %UentityExp(M.TYCexp t))
1131 :     | entityExp #"S" = ?strExp(fn UstrExp t => %UentityExp(M.STRexp t))
1132 :     | entityExp #"F" = ?fctExp(fn UfctExp t => %UentityExp(M.FCTexp t))
1133 :     | entityExp #"D" = %UentityExp(M.DUMMYexp)
1134 :     | entityExp #"E" = %UentityExp(M.ERRORexp)
1135 :     | entityExp _ = raise Fail " | entityExp"
1136 :    
1137 :     and entityDec #"T" = ?entVar(fn Ustamp s => ?tycExp(fn UtycExp x =>
1138 :     %UentityDec(M.TYCdec(s,x))))
1139 :     | entityDec #"S" = ?entVar(fn Ustamp s => ?strExp(fn UstrExp x =>
1140 :     ?symbol(fn Usymbol n =>
1141 :     %UentityDec(M.STRdec(s,x,n)))))
1142 :     | entityDec #"F" = ?entVar(fn Ustamp s => ?fctExp(fn UfctExp x =>
1143 :     %UentityDec(M.FCTdec(s,x))))
1144 :     | entityDec #"Q" = ?entityDecList(fn UentityDecList e =>
1145 :     %UentityDec(M.SEQdec e))
1146 :     | entityDec #"L" = ?entityDec(fn UentityDec a =>
1147 :     ?entityDec(fn UentityDec b =>
1148 :     %UentityDec(M.LOCALdec(a,b))))
1149 :     | entityDec #"E" = %UentityDec M.ERRORdec
1150 :     | entityDec #"M" = %UentityDec M.EMPTYdec
1151 :     | entityDec _ = raise Fail " | entityDec"
1152 :    
1153 :     and entityDecList x = list(?entityDec,fn UentityDec t => t,
1154 :     fn UentityDecList t => t, UentityDecList) x
1155 :    
1156 :    
1157 :     and entityEnv #"X" =
1158 :     ?modId(fn UmodId id =>
1159 :     case SCStaticEnv.lookEENV context0 id
1160 :     of SOME e => %UentityEnv e
1161 :     | NONE => raise Fail "missing external entityEnv")
1162 :     | entityEnv #"M" = ?stamp(fn Ustamp s =>
1163 :     ?entityEnv(fn UentityEnv r =>
1164 :     %UentityEnv(M.MARKeenv(s,r))))
1165 :     | entityEnv #"B" =
1166 :     ?entVElist(fn UentVElist vs =>
1167 :     ?entityEnv(fn UentityEnv r =>
1168 :     %UentityEnv(M.BINDeenv(
1169 :     foldr (fn ((v,e), z) => ED.insert(z,v,e)) (ED.mkDict()) vs,
1170 :     r))))
1171 :     | entityEnv #"N" = %UentityEnv(M.NILeenv)
1172 :     | entityEnv #"E" = %UentityEnv(M.ERReenv)
1173 :    
1174 :     | entityEnv _ = raise Fail " | entityEnv"
1175 :    
1176 :     and entVElist x = list (?entVETuple, fn UentVETuple x => x,
1177 :     fn UentVElist x => x, UentVElist) x
1178 :    
1179 :     and entVETuple #"T" = ?entVar (fn Ustamp v =>
1180 :     ?entity (fn Uentity e => %UentVETuple(v, e)))
1181 :     | entVETuple _ = raise Fail " | entVETuple"
1182 :    
1183 :     and strEntity #"S" = ?stamp(fn Ustamp s =>
1184 :     ?entityEnv(fn UentityEnv e =>
1185 :     ?ipath(fn UsymbolList r =>
1186 :     %UstrEntity{stamp=s,entities=e,
1187 :     lambdaty=ref NONE,
1188 :     rpath=IP.IPATH r})))
1189 :    
1190 :     | strEntity _ = raise Fail " | strEntity"
1191 :    
1192 :     and fctEntity #"F" = ?stamp(fn Ustamp s =>
1193 :     ?fctClosure(fn UfctClosure c =>
1194 :     ?ipath(fn UsymbolList r =>
1195 :     %UfctEntity{stamp=s,closure=c,
1196 :     lambdaty=ref NONE,
1197 :     tycpath=NONE, rpath=IP.IPATH r})))
1198 :    
1199 :     | fctEntity _ = raise Fail " | fctEntity"
1200 :    
1201 :     and tycEntity x = tycon x
1202 :    
1203 :    
1204 :     fun fixity #"N" = %Ufixity Fixity.NONfix
1205 :     | fixity #"I" =
1206 :     R.int(fn i => R.int(fn j => %Ufixity(Fixity.INfix(i,j))))
1207 :     | fixity _ = raise Fail " | fixity"
1208 :    
1209 :     fun binding #"V" = ?var(fn Uvar x => %Ubinding(B.VALbind x))
1210 :     | binding #"C" = ?datacon(fn Udatacon x => %Ubinding(B.CONbind x))
1211 :     | binding #"T" = ?tycon(fn Utycon x => %Ubinding(B.TYCbind x))
1212 :     | binding #"G" = ?Signature(fn USignature x => %Ubinding(B.SIGbind x))
1213 :     | binding #"S" = ?Structure(fn UStructure x => %Ubinding(B.STRbind x))
1214 :     | binding #"I" = ?fctSig(fn UfctSig x => %Ubinding(B.FSGbind x))
1215 :     | binding #"F" = ?Functor(fn UFunctor x => %Ubinding(B.FCTbind x))
1216 :     | binding #"X" = ?fixity(fn Ufixity x => %Ubinding(B.FIXbind x))
1217 :     | binding _ = raise Fail " | binding"
1218 :    
1219 :     fun bind #"T" = ?symbol(fn Usymbol s =>
1220 :     ?binding(fn Ubinding b =>
1221 :     %Ubind(s,b)))
1222 :     | bind _ = raise Fail " | bind"
1223 :    
1224 :     val bindList = list(?bind, fn Ubind t => t,
1225 :     fn UbindList t => t, UbindList)
1226 :    
1227 :     fun env #"E" = ?bindList(fn UbindList l =>
1228 :     %Uenv(Env.consolidate(foldr(fn((s,b),e)=>Env.bind(s,b,e))
1229 :     Env.empty l)))
1230 :     | env _ = raise Fail " | env"
1231 :    
1232 :     val Uenv result = R.root(p0,env)
1233 :    
1234 :     in result
1235 :     end (* function unPickleEnv *)
1236 :    
1237 :     end (* local *)
1238 :     end (* structure UnpickleMod *)
1239 :    

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