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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 904 - (download) (annotate)
Mon Aug 20 19:50:05 2001 UTC (19 years, 1 month ago) by blume
File size: 1245 byte(s)
fixed a minor slipup
(* coreacc.sml
 *
 * (C) 2001 Lucent Technologies, Bell Labs
 *)
structure CoreAccess : sig
    val getVar : StaticEnv.staticEnv * string -> VarCon.var
    val getCon : StaticEnv.staticEnv * string -> VarCon.datacon
    val getVar' : (unit -> VarCon.var) ->
		  StaticEnv.staticEnv * string -> VarCon.var
    val getCon' : (unit -> VarCon.datacon) ->
		  StaticEnv.staticEnv * string -> VarCon.datacon

    (* like getCon, but returns a bogus exn instead of failing *)
    val getExn : StaticEnv.staticEnv * string -> VarCon.datacon
end = struct

    local
	exception NoCore
	fun dummyErr _ _ _ = raise NoCore
	fun path name = SymPath.SPATH [CoreSym.coreSym,Symbol.varSymbol name]
	fun getCore (env, s) = Lookup.lookVal (env, path s, dummyErr)

	fun impossible m = ErrorMsg.impossible ("CoreAccess: " ^ m)
    in
	fun getVar' err x =
	    (case getCore x of
		 VarCon.VAL r => r
	       | _ => impossible "getVar")
	    handle NoCore => err ()

	fun getVar x = getVar' (fn () => impossible "getVar") x

	fun getCon' err x =
	    (case getCore x of
		 VarCon.CON c => c
	       | _ => err ())
	    handle NoCore => err ()

	fun getCon x = getCon' (fn () => impossible "getCon") x

	fun getExn x = getCon' (fn () => VarCon.bogusEXN) x
    end
end

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