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

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

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