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

Annotation of /sml/trunk/src/compiler/Semant/modules/expandtycon.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 signature EXPAND_TYCON =
2 :     sig
3 :     type sigContext = Modules.elements list
4 :     val expandTycon : Types.tycon * sigContext * EntityEnv.entityEnv -> Types.tycon
5 :     val debugging : bool ref
6 :     end
7 :    
8 :     structure ExpandTycon : EXPAND_TYCON =
9 :     struct
10 :    
11 :     local (* imported structures *)
12 :     structure T = Types
13 :     structure TU = TypesUtil
14 :     structure EP = EntPath
15 :     structure M = Modules
16 :     structure MU = ModuleUtil
17 :     in
18 :    
19 :     (* debugging hooks *)
20 :     val say = Control.Print.say
21 :     val debugging = ref false
22 :     fun debugmsg (msg: string) =
23 :     if !debugging then (say msg; say "\n") else ()
24 :     fun bug s = ErrorMsg.impossible ("ExpandTycon: " ^ s)
25 :    
26 :     type sigContext = M.elements list
27 :    
28 :     exception OUTER
29 :    
30 :     (* ignoring FCTspec - won't find any types there *)
31 :     fun lookEntVar(ev,(_,s as (M.TYCspec{entVar,...} | M.STRspec{entVar,...}))::rest) =
32 :     if EP.eqEntVar(ev,entVar) then SOME s else lookEntVar(ev,rest)
33 :     | lookEntVar(ev,_::rest) = lookEntVar(ev,rest)
34 :     | lookEntVar(ev,nil) = NONE
35 :    
36 :     fun findContext(ev,context as elements0::outer) =
37 :     (case lookEntVar(ev, elements0)
38 :     of SOME(M.STRspec{sign as M.SIG{elements,...},...}) =>
39 :     elements::context
40 :     | NONE => findContext(ev,outer)
41 :     | _ => bug "findContext - bad element")
42 :     | findContext(ev,nil) = raise OUTER
43 :    
44 :     fun expandTycon(tycon,context,entEnv) =
45 :     let fun expandTycVar(ev,context as elements::outer) : T.tycon =
46 :     (case lookEntVar(ev, elements)
47 :     of SOME(M.TYCspec{spec,...}) =>
48 :     (case spec
49 :     of T.GENtyc _ => spec
50 :     | T.DEFtyc{stamp,strict,path,tyfun} =>
51 :     T.DEFtyc{stamp=stamp,strict=strict,path=path,
52 :     tyfun=expandTyfun(tyfun,context)})
53 :     | NONE => (* try outer context *)
54 :     expandTycVar(ev,outer)
55 :     | _ => bug "expandTycon 1")
56 :     | expandTycVar(ev,nil) = raise OUTER
57 :    
58 :     and expandTyc context =
59 :     fn (tyc as T.PATHtyc{entPath,...}) =>
60 :     (expandPath(entPath,context)
61 :     handle OUTER => (* path outside current signature context *)
62 :     MU.transTycon entEnv tyc)
63 :     | tyc => tyc
64 :    
65 :     and expandTyfun(T.TYFUN{arity,body},context) =
66 :     T.TYFUN{arity=arity,
67 :     body=TU.mapTypeFull (expandTyc context) body}
68 :    
69 :     and expandPath(ep, context) =
70 :     (case ep
71 :     of nil => bug "expandPath 1"
72 :     | ev :: nil => (* tycon! *)
73 :     expandTycVar(ev,context)
74 :     | ev :: rest => (* substructure! *)
75 :     expandPath(rest,findContext(ev, context)))
76 :    
77 :     in expandTyc context tycon
78 :     end
79 :    
80 :     end (* local *)
81 :     end (* structure ExpandTycon *)
82 :    
83 :     (*
84 :     * $Log: expandtycon.sml,v $
85 :     * Revision 1.3 1997/04/02 04:06:45 dbm
86 :     * Removed redundant rule in function expandPath.
87 :     *
88 :     * Revision 1.2 1997/02/26 15:38:39 dbm
89 :     * Fix bug 1141. Added entityEnv parameter to expandTycon and rewrote body of
90 :     * module so that the entityEnv parameter would be used if a path could not be
91 :     * interpreted in the sigContext parameter.
92 :     *
93 :     * Revision 1.1.1.1 1997/01/14 01:38:42 george
94 :     * Version 109.24
95 :     *
96 :     *)

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