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 220 - (view) (download)

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

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