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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 24 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/Semant/modules/epcontext.sml

1 : monnier 16 (* Copyright 1996 by AT&T Bell Laboratories *)
2 :     (* epcontext.sml *)
3 :    
4 :     signature ENT_PATH_CONTEXT =
5 :     sig
6 :    
7 :     type context
8 :    
9 :     val initContext : context
10 :     val isEmpty : context -> bool
11 :     val enterOpen : context * EntPath.entVar option -> context
12 :     val enterClosed : context -> context
13 :     val lookPath : context * ModuleId.modId -> EntPath.entPath option
14 :     val bindPath : context * ModuleId.modId * EntPath.entVar -> unit
15 :     val bindLongPath : context * ModuleId.modId * EntPath.entPath -> unit
16 :    
17 :     end (* signature ENT_PATH_CONTEXT *)
18 :    
19 :    
20 :     structure EntPathContext :> ENT_PATH_CONTEXT =
21 :     struct
22 :    
23 :     local structure ST = Stamps
24 :     structure EP = EntPath
25 :     structure MI = ModuleId
26 :     in
27 :    
28 :     structure Key =
29 :     struct
30 :     type ord_key = MI.modId
31 :     val cmpKey = MI.cmp
32 :     end
33 :    
34 :     structure D = BinaryDict(Key)
35 :    
36 :     type entPathR = EP.entVar list
37 :     type pathmap = entPathR D.dict
38 :    
39 :     (*
40 :     * A structure body (struct decls end) is "closed" if
41 :     * it is a functor body structure
42 :     * The idea is that the elements of a closed structure are not
43 :     * directly referenced from outside the structure, so the pathEnv
44 :     * local to the closed structure can be discarded after the structure
45 :     * body is elaborated.
46 :     *)
47 :    
48 :     (* pathmap maps stamps to full entPaths relative to current functor context *)
49 :     (* each "closed" structure body pushes a new layer *)
50 :     datatype context
51 :     = EMPTY
52 :     | LAYER of {locals: pathmap ref,
53 :     lookContext: EP.entPath,
54 :     bindContext: entPathR,
55 :     outer: context}
56 :    
57 :     val initContext : context = EMPTY
58 :    
59 :     fun isEmpty(EMPTY : context) = true
60 :     | isEmpty _ = false
61 :    
62 :     (*
63 :     * called on entering a closed structure scope, whose elements will not
64 :     * be accessed from outside (hence the null bindContext)
65 :     *)
66 :     fun enterClosed epc =
67 :     LAYER {locals=ref(D.mkDict()), lookContext=[],
68 :     bindContext=[], outer=epc}
69 :    
70 :     (*
71 :     * called on entering an open structure scope (claim: this is always an
72 :     * unconstrained structure decl body), where ev is the entVar of the
73 :     * structure being elaborated.
74 :     *)
75 :     fun enterOpen (EMPTY, _) = EMPTY
76 :     | enterOpen (epc, NONE) = epc
77 :     | enterOpen (LAYER{locals,lookContext,bindContext,outer}, SOME ev) =
78 :     LAYER{locals=locals, lookContext=lookContext@[ev],
79 :     bindContext=ev::bindContext, outer=outer}
80 :    
81 :     (* relative(path,ctx) - subtract common prefix of path and ctx from path *)
82 :     fun relative([],_) = []
83 :     | relative(ep,[]) = ep
84 :     | relative(p as (x::rest),y::rest') =
85 :     if EP.eqEntVar(x,y) then relative(rest,rest') else p
86 :    
87 :     fun lookPath (EMPTY, _) = NONE
88 :     | lookPath (LAYER{locals,lookContext,bindContext,outer}, id: MI.modId)
89 :     : entPathR option =
90 :     (case D.peek(!locals,id)
91 :     of NONE => lookPath(outer,id)
92 :     | SOME rp => SOME(relative(rev rp, lookContext)))
93 :    
94 :     (* probe(ctx,s) checks whether a stamp has already be bound before *)
95 :     fun probe (EMPTY, s) = false
96 :     | probe (LAYER{locals, outer, ...}, s) =
97 :     (case D.peek(!locals, s)
98 :     of NONE => probe(outer, s)
99 :     | _ => true)
100 :    
101 :     fun bindPath (EMPTY, _, _) = ()
102 :     | bindPath (xx as LAYER {locals, bindContext, ...}, s, ev) =
103 :     if probe(xx, s) then ()
104 :     else (locals := D.insert(!locals, s, ev::bindContext))
105 :    
106 :     fun bindLongPath(EMPTY, _, _) = ()
107 :     | bindLongPath(xx as LAYER {locals, bindContext, ...}, s, ep) =
108 :     let fun h(a::r, p) = h(r, a::p)
109 :     | h([], p) = p
110 :     in if probe(xx, s) then ()
111 :     else (locals := D.insert(!locals, s, h(ep,bindContext)))
112 :     end
113 :    
114 : monnier 24 (*
115 :     (*** top leve wrappers: used for profiling the compilation time *)
116 :     val lookPath =
117 :     Stats.doPhase (Stats.makePhase "Compiler 034 x-lookPath") lookPath
118 :     val bindPath =
119 :     Stats.doPhase (Stats.makePhase "Compiler 034 x-bindPath") bindPath
120 :     val bindLongPath =
121 :     Stats.doPhase (Stats.makePhase "Compiler 034 y-bindPath") bindLongPath
122 :     *)
123 :    
124 : monnier 16 end (* local *)
125 :     end (* structure EntPathContext *)
126 :    
127 :     (*
128 :     * $Log: epcontext.sml,v $
129 :     * Revision 1.6 1997/09/23 03:53:36 dbm
130 :     * Rewrite for EntityEnv.Unbound fix (bugs 1270, 1271, etc.)
131 :     *
132 :     * Revision 1.5 1997/08/28 12:37:08 jhr
133 :     * Replaced insertNovwt witn insertSp [zsh]
134 :     *
135 :     * Revision 1.4 1997/08/22 18:37:41 george
136 :     * Add several new functions and simplifications to fix bug 1234, 1206, etc.
137 :     * --- zsh
138 :     *
139 :     * Revision 1.2 1997/01/31 20:40:05 jhr
140 :     * Replaced uses of "abstraction" with opaque signature matching.
141 :     *
142 :     * Revision 1.1.1.1 1997/01/14 01:38:42 george
143 :     * Version 109.24
144 :     *
145 :     *)

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