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

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

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

revision 2623, Tue May 29 21:53:56 2007 UTC revision 2624, Tue May 29 23:00:44 2007 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
6      val getVar : StaticEnv.staticEnv * string -> VarCon.var      val getVar : StaticEnv.staticEnv -> string list -> VarCon.var
7      val getCon : StaticEnv.staticEnv * string -> VarCon.datacon      val getCon : StaticEnv.staticEnv -> string list -> VarCon.datacon
8      val getVar' : (unit -> VarCon.var) ->      val getVar' : (unit -> VarCon.var) ->
9                    StaticEnv.staticEnv * string -> VarCon.var                    StaticEnv.staticEnv -> string list -> VarCon.var
10      val getCon' : (unit -> VarCon.datacon) ->      val getCon' : (unit -> VarCon.datacon) ->
11                    StaticEnv.staticEnv * string -> VarCon.datacon                    StaticEnv.staticEnv -> string list -> VarCon.datacon
12    
13      (* like getCon, but returns a bogus exn instead of failing *)      (* like getCon, but returns a bogus exn instead of failing *)
14      val getExn : StaticEnv.staticEnv * string -> VarCon.datacon      val getExn : StaticEnv.staticEnv -> string list -> VarCon.datacon
15  end = struct  end = struct
16    
17      local      local
18            fun impossible m = ErrorMsg.impossible ("CoreAccess: " ^ m)
19    
20          exception NoCore          exception NoCore
21          fun dummyErr _ _ _ = raise NoCore          fun dummyErr _ _ _ = raise NoCore
22          fun path name = SymPath.SPATH [CoreSym.coreSym,Symbol.varSymbol name]          fun mkpath [] = impossible "mkpath"
23          fun getCore (env, s) = Lookup.lookVal (env, path s, dummyErr)            | mkpath [x] = [Symbol.varSymbol x]
24              | mkpath (x :: xs) = Symbol.strSymbol x :: mkpath xs
25          fun impossible m = ErrorMsg.impossible ("CoreAccess: " ^ m)          fun path xs = SymPath.SPATH (CoreSym.coreSym :: mkpath xs)
26            fun getCore env xs = Lookup.lookVal (env, path xs, dummyErr)
27      in      in
28          fun getVar' err x =          fun getVar' err env xs =
29              (case getCore x of              (case getCore env xs of
30                   VarCon.VAL r => r                   VarCon.VAL r => r
31                 | _ => impossible "getVar")                 | _ => impossible "getVar")
32              handle NoCore => err ()              handle NoCore => err ()
33    
34          fun getVar x = getVar' (fn () => impossible "getVar") x          fun getVar env xs = getVar' (fn () => impossible "getVar") env xs
35    
36          fun getCon' err x =          fun getCon' err env xs =
37              (case getCore x of              (case getCore env xs of
38                   VarCon.CON c => c                   VarCon.CON c => c
39                 | _ => err ())                 | _ => err ())
40              handle NoCore => err ()              handle NoCore => err ()
41    
42          fun getCon x = getCon' (fn () => impossible "getCon") x          fun getCon env xs = getCon' (fn () => impossible "getCon") env xs
43    
44          fun getExn x = getCon' (fn () => VarCon.bogusEXN) x          fun getExn env xs = getCon' (fn () => VarCon.bogusEXN) env xs
45      end      end
46  end  end

Legend:
Removed from v.2623  
changed lines
  Added in v.2624

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