Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/ElabData/statenv/coreacc.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 903, Mon Aug 20 19:34:06 2001 UTC revision 904, Mon Aug 20 19:50:05 2001 UTC
# Line 3  Line 3 
3   * (C) 2001 Lucent Technologies, Bell Labs   * (C) 2001 Lucent Technologies, Bell Labs
4   *)   *)
5  structure CoreAccess : sig  structure CoreAccess : sig
     exception NoCore  
     val getExn : StaticEnv.staticEnv * string -> VarCon.datacon  
6      val getVar : StaticEnv.staticEnv * string -> VarCon.var      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        val getExn : StaticEnv.staticEnv * string -> VarCon.datacon
15  end = struct  end = struct
16    
17        local
18      exception NoCore      exception NoCore
19      fun dummyErr _ _ _ = raise NoCore      fun dummyErr _ _ _ = raise NoCore
20      fun path name = SymPath.SPATH [CoreSym.coreSym,Symbol.varSymbol name]      fun path name = SymPath.SPATH [CoreSym.coreSym,Symbol.varSymbol name]
21            fun getCore (env, s) = Lookup.lookVal (env, path s, dummyErr)
22    
23      fun getExn (env, name) =          fun impossible m = ErrorMsg.impossible ("CoreAccess: " ^ m)
24          (case Lookup.lookVal (env, path name, dummyErr) of      in
25               VarCon.CON x => x          fun getVar' err x =
26             | _ => VarCon.bogusEXN)              (case getCore x of
27          handle NoCore => VarCon.bogusEXN                   VarCon.VAL r => r
28                   | _ => impossible "getVar")
29      fun getVar (env, name) =              handle NoCore => err ()
30          (case Lookup.lookVal (env, path name, dummyErr) of  
31               VarCon.VAL v => v          fun getVar x = getVar' (fn () => impossible "getVar") x
32             | _ => raise NoCore)  
33          handle NoCore =>          fun getCon' err x =
34                 raise Fail ("CoreAccess.getVar: cannot access " ^ name)              (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  end  end

Legend:
Removed from v.903  
changed lines
  Added in v.904

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