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

Annotation of /sml/trunk/src/compiler/ElabData/statenv/coreacc.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 904 - (view) (download)

1 : blume 903 (* coreacc.sml
2 :     *
3 :     * (C) 2001 Lucent Technologies, Bell Labs
4 :     *)
5 :     structure CoreAccess : sig
6 : blume 904 val getVar : StaticEnv.staticEnv * string -> VarCon.var
7 :     val getCon : StaticEnv.staticEnv * string -> VarCon.datacon
8 :     val getVar' : (unit -> VarCon.var) ->
9 :     StaticEnv.staticEnv * string -> VarCon.var
10 :     val getCon' : (unit -> VarCon.datacon) ->
11 :     StaticEnv.staticEnv * string -> VarCon.datacon
12 :    
13 :     (* like getCon, but returns a bogus exn instead of failing *)
14 : blume 903 val getExn : StaticEnv.staticEnv * string -> VarCon.datacon
15 :     end = struct
16 :    
17 : blume 904 local
18 :     exception NoCore
19 :     fun dummyErr _ _ _ = raise NoCore
20 :     fun path name = SymPath.SPATH [CoreSym.coreSym,Symbol.varSymbol name]
21 :     fun getCore (env, s) = Lookup.lookVal (env, path s, dummyErr)
22 : blume 903
23 : blume 904 fun impossible m = ErrorMsg.impossible ("CoreAccess: " ^ m)
24 :     in
25 :     fun getVar' err x =
26 :     (case getCore x of
27 :     VarCon.VAL r => r
28 :     | _ => impossible "getVar")
29 :     handle NoCore => err ()
30 :    
31 :     fun getVar x = getVar' (fn () => impossible "getVar") x
32 :    
33 :     fun getCon' err x =
34 :     (case getCore x of
35 :     VarCon.CON c => c
36 :     | _ => err ())
37 :     handle NoCore => err ()
38 :    
39 :     fun getCon x = getCon' (fn () => impossible "getCon") x
40 :    
41 :     fun getExn x = getCon' (fn () => VarCon.bogusEXN) x
42 :     end
43 : blume 903 end

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