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

Annotation of /sml/trunk/src/compiler/Semant/statenv/lookup.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 651 - (view) (download)

1 : monnier 249 (* COPYRIGHT (c) 1996 Bell Laboratories. *)
2 :     (* lookup.sml *)
3 :    
4 :     structure Lookup : LOOKUP =
5 :     struct
6 :    
7 :     local structure SP = SymPath
8 :     structure CVP = ConvertPaths
9 :     structure M = Modules
10 :     structure MU = ModuleUtil
11 :     structure T = Types
12 :     structure TU = TypesUtil
13 :     structure A = Access
14 :     structure V = VarCon
15 :     structure B = Bindings
16 :     structure SE = StaticEnv
17 :     structure EM = ErrorMsg
18 :     structure S = Symbol
19 :     in
20 :    
21 :     fun bug s = EM.impossible ("Lookup: "^s)
22 :    
23 :     fun spmsg spath =
24 :     if SP.length spath > 1 then " in path "^(SP.toString spath) else ""
25 :    
26 :     fun unboundError(badsym, sp, err) =
27 :     err EM.COMPLAIN ("unbound " ^
28 :     S.nameSpaceToString(S.nameSpace badsym) ^
29 :     ": " ^ S.name badsym ^ sp) EM.nullErrorBody
30 :    
31 :     fun otherError(s, err) = err EM.COMPLAIN s EM.nullErrorBody
32 :    
33 :     (* error values for undefined structure and functor variables *)
34 :     val bogusSTR = M.ERRORstr
35 :     val bogusFCT = M.ERRORfct
36 :     val bogusVAL = V.VAL V.ERRORvar
37 :    
38 :     (*** look for a fixity binding ***)
39 :     fun lookFix (env,id) : Fixity.fixity =
40 : blume 587 let val b = case SE.look(env,id)
41 : monnier 249 of B.FIXbind fixity => fixity
42 :     | _ => bug "lookFIX"
43 :     in b
44 : blume 587 end handle SE.Unbound => Fixity.NONfix
45 : monnier 249
46 :     (*** look for a signature ***)
47 :     fun lookSig (env,id,err) : M.Signature =
48 : blume 587 let val b = case SE.look(env,id)
49 : monnier 249 of B.SIGbind sign => sign
50 :     | _ => bug "lookSIG"
51 :     in b
52 : blume 587 end handle SE.Unbound => (unboundError(id,"",err); M.ERRORsig)
53 : monnier 249
54 :     (*** look for a functor signature ***)
55 :     fun lookFsig (env,id,err) : M.fctSig =
56 : blume 587 let val b = case SE.look(env,id)
57 : monnier 249 of B.FSGbind fs => fs
58 :     | _ => bug "lookFSIG"
59 :     in b
60 : blume 587 end handle SE.Unbound => (unboundError(id,"",err); M.ERRORfsig)
61 : monnier 249
62 :     (*** look for a variable or a constructor bound to a symbol ***)
63 :     fun lookValSym (env,sym,err) : V.value =
64 :     let val b = case SE.look(env,sym)
65 :     of B.VALbind v => V.VAL v
66 :     | B.CONbind c => V.CON c
67 :     | _ => bug "lookValSym"
68 :     in b
69 :     end handle SE.Unbound => (unboundError(sym,"",err); bogusVAL)
70 :    
71 :    
72 :     (*** lookup path ****)
73 :    
74 :     (*
75 :     * lookGen: generic lookup function for identifiers which may occur in:
76 :     * 1. environments
77 :     * 2. actual structure environments
78 :     * 3. signature parsing environments
79 :     *)
80 : blume 587 fun lookGen(env,spath,outBind,getPath,errorVal,err) =
81 :     case spath of
82 :     SP.SPATH [id] =>
83 :     (outBind(SE.look(env,id))
84 :     handle SE.Unbound => (unboundError(id,spmsg spath,err); errorVal))
85 :     | SP.SPATH(first::rest) =>
86 :     ((case SE.look(env,first)
87 :     of B.STRbind str =>
88 :     (getPath(str,SP.SPATH rest,spath)
89 :     handle MU.Unbound sym =>
90 : monnier 249 (unboundError(sym,spmsg spath,err); errorVal))
91 : blume 587 | _ => bug "lookGen1")
92 :     handle SE.Unbound => (unboundError(first,spmsg spath,err);
93 :     errorVal))
94 :     | SP.SPATH [] => bug "lookGen:SP.SPATH[]"
95 : monnier 249
96 :     (*** look for a variable or a constructor (complete path) ***)
97 :     fun lookVal(env,path,err) : V.value =
98 :     let fun outVal(B.VALbind v) = V.VAL v
99 :     | outVal(B.CONbind c) = V.CON c
100 :     | outVal _ = bug "outVal"
101 :     in lookGen(env,path,outVal,MU.getValPath,bogusVAL,err)
102 :     end
103 :    
104 :     (*** look for a structure ***)
105 :     fun lookStr(env,path,err) : M.Structure =
106 :     let fun outStr(B.STRbind str) = str
107 :     | outStr _ = bug "lookStr"
108 :     in lookGen(env,path,outStr,MU.getStrPath,bogusSTR,err)
109 :     end
110 :    
111 :     (*** look for a strDef; used in elabsig.sml ***)
112 :     fun lookStrDef(env,path,err) : M.strDef =
113 : blume 587 let fun outSD(B.STRbind s) =
114 :     (case s of
115 :     M.STRSIG{sign,entPath} => M.VARstrDef(sign,entPath)
116 :     | sv => M.CONSTstrDef sv)
117 : monnier 249 | outSD _ = bug "lookStrDef"
118 :     in lookGen(env,path,outSD,MU.getStrDef,M.CONSTstrDef bogusSTR,err)
119 :     end
120 :    
121 :     (*** look for a functor ***)
122 :     fun lookFct(env,path,err) : M.Functor =
123 :     let fun outFct(B.FCTbind fct) = fct
124 :     | outFct _ = bug "lookFct"
125 :     in lookGen(env,path,outFct,MU.getFctPath,bogusFCT,err)
126 :     end
127 :    
128 :     (*** look for a type constructor ***)
129 :     fun lookTyc(env,path,err) : T.tycon =
130 :     let fun outTyc(B.TYCbind tycon) = tycon
131 :     | outTyc _ = bug "lookTyc"
132 :     in lookGen(env,path,outTyc,MU.getTycPath,T.ERRORtyc,err)
133 :     end
134 :    
135 :     (*** tycon lookup with arity checking ***)
136 :     fun lookArTyc (env, path, arity, err) =
137 :     (case lookTyc(env,path,err)
138 :     of T.ERRORtyc => T.ERRORtyc
139 :     | tycon =>
140 :     if TU.tyconArity(tycon) <> arity
141 :     then (otherError("type constructor " ^
142 :     (SP.toString(CVP.invertIPath(TU.tycPath(tycon)))) ^
143 :     " given " ^ (Int.toString arity) ^ " arguments, wants "
144 :     ^ (Int.toString (TU.tyconArity tycon)), err);
145 :     T.ERRORtyc)
146 :     else tycon)
147 :    
148 :     (*** looking for an exception ***)
149 :     fun lookExn (env,path,err) : V.datacon =
150 :     (case lookVal(env,path,err)
151 :     of V.CON(c as T.DATACON{rep=(A.EXN _), ...}) => c
152 :     | V.CON _ =>
153 :     (otherError("found data constructor instead of exception", err);
154 :     V.bogusEXN)
155 :     | V.VAL _ =>
156 :     (otherError("found variable instead of exception", err);
157 :     V.bogusEXN))
158 :    
159 :     end (* local *)
160 :     end (* structure Lookup *)
161 :    

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