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/Semant/modules/expandtycon.sml
ViewVC logotype

View of /sml/trunk/src/compiler/Semant/modules/expandtycon.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 419 - (download) (annotate)
Fri Sep 3 23:51:27 1999 UTC (19 years, 9 months ago) by monnier
File size: 2414 byte(s)
This commit was generated by cvs2svn to compensate for changes in r418,
which included commits to RCS files with non-trunk default branches.
signature EXPAND_TYCON =
sig
  type sigContext = Modules.elements list
  val expandTycon : Types.tycon * sigContext * EntityEnv.entityEnv -> Types.tycon
  val debugging : bool ref
end

structure ExpandTycon : EXPAND_TYCON =
struct

local (* imported structures *)
  structure T = Types
  structure TU = TypesUtil
  structure EP = EntPath
  structure M = Modules
  structure MU = ModuleUtil
in

(* debugging hooks *)
val say = Control.Print.say
val debugging = ref false
fun debugmsg (msg: string) =
      if !debugging then (say msg; say "\n") else ()
fun bug s = ErrorMsg.impossible ("ExpandTycon: " ^ s)

type sigContext = M.elements list

exception OUTER

(* ignoring FCTspec - won't find any types there *)
fun lookEntVar(ev,(_,s as (M.TYCspec{entVar,...} | M.STRspec{entVar,...}))::rest) =
      if EP.eqEntVar(ev,entVar) then SOME s else lookEntVar(ev,rest)
  | lookEntVar(ev,_::rest) = lookEntVar(ev,rest)
  | lookEntVar(ev,nil) = NONE

fun findContext(ev,context as elements0::outer) =
      (case lookEntVar(ev, elements0)
	 of SOME(M.STRspec{sign as M.SIG{elements,...},...}) =>
	     elements::context
	  | NONE => findContext(ev,outer)
	  | _ => bug "findContext - bad element")
  | findContext(ev,nil) = raise OUTER

fun expandTycon(tycon,context,entEnv) =
    let fun expandTycVar(ev,context as elements::outer) : T.tycon =
	      (case lookEntVar(ev, elements)
		 of SOME(M.TYCspec{spec,...}) =>
		     (case spec
			of T.GENtyc _ => spec
			 | T.DEFtyc{stamp,strict,path,tyfun} =>
			     T.DEFtyc{stamp=stamp,strict=strict,path=path,
				      tyfun=expandTyfun(tyfun,context)})
		  | NONE => (* try outer context *)
		     expandTycVar(ev,outer)
		  | _ => bug "expandTycon 1")
	  | expandTycVar(ev,nil) = raise OUTER

	and expandTyc context = 
	     fn (tyc as T.PATHtyc{entPath,...}) =>
	         (expandPath(entPath,context)
		  handle OUTER => (* path outside current signature context *)
		    MU.transTycon entEnv tyc)
	      | tyc => tyc

	and expandTyfun(T.TYFUN{arity,body},context) = 
	     T.TYFUN{arity=arity,
		     body=TU.mapTypeFull (expandTyc context) body}

	and expandPath(ep, context) =
	    (case ep
	       of nil => bug "expandPath 1"
		| ev :: nil =>  (* tycon! *)
		   expandTycVar(ev,context)
		| ev :: rest => (* substructure! *)
		   expandPath(rest,findContext(ev, context)))

     in expandTyc context tycon
    end

end (* local *)
end (* structure ExpandTycon *)


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