(*
 * ast-to-spec.sml - Conversion from CKIT "ast" to a "spec" (see spec.sml).
 *
 *  (C) 2001, Lucent Technologies, Bell Labs
 *
 * author: Matthias Blume (blume@research.bell-labs.com)
 *)
structure AstToSpec = struct

    structure A = Ast
    structure B = Bindings

    structure SS = StringSet
    structure SM = StringMap

    datatype context = CONTEXT of { gensym: unit -> string, anon: bool }

    exception VoidType
    exception Ellipsis
    exception Duplicate of string

    fun bug m = raise Fail ("AstToSpec: bug: " ^ m)
    fun err m = raise Fail ("AstToSpec: error: " ^ m)
    fun warn m = TextIO.output (TextIO.stdErr, "AstToSpec: warning: " ^ m)

    fun build { bundle, sizes: Sizes.sizes, collect_enums,
		cfiles, match, allSU, eshift, gensym_suffix } =
    let

	val curLoc = ref "?"

	fun warnLoc m = warn (concat [!curLoc, ": ", m])

	val { ast, tidtab, errorCount, warningCount,
	      auxiliaryInfo = { aidtab, implicits, env } } = bundle

	fun realFunctionDefComing sy = let
	    fun isTheDef (A.DECL (A.FunctionDef (id, _, _), _, _)) =
		Symbol.equal (#name id, sy)
	      | isTheDef _ = false
	in
	    List.exists isTheDef ast
	end

	val srcOf = SourceMap.locToString

	fun isThisFile SourceMap.UNKNOWN = false
	  | isThisFile (SourceMap.LOC { srcFile, ... }) =
	    List.exists (fn f => f = srcFile) cfiles orelse
	    match srcFile

	fun includedSU (tag, loc) = (allSU orelse isThisFile loc)
	fun includedEnum (tag, loc) = isThisFile loc

	fun includedTy (n, loc) = isThisFile loc

	fun isFunction t = TypeUtil.isFunction tidtab t
	fun getFunction t = TypeUtil.getFunction tidtab t
	fun getCoreType t = TypeUtil.getCoreType tidtab t

	fun constness t =
	    if TypeUtil.isConst tidtab t then Spec.RO
	    else case getCoreType t of
		     A.Array (_, t) => constness t
		   | _ => Spec.RW

	val sizerec = { sizes = sizes, err = err, warn = warn, bug = bug }

	fun sizeOf t = #bytes (Sizeof.byteSizeOf sizerec tidtab t)

	val bytebits = #bits (#char sizes)
	val intbits = #bits (#int sizes)
	val intalign = #align (#int sizes)

	fun getField (m, l) = Sizeof.getField sizerec (m, l)

	fun fieldOffsets t =
	    case Sizeof.fieldOffsets sizerec tidtab t of
		NONE => bug "no field offsets"
	      | SOME l => l

	val structs = ref []
	val unions = ref []
	val gtys = ref SM.empty
	val gvars = ref SM.empty
	val gfuns = ref SM.empty
	val named_enums = ref SM.empty
	val anon_enums = ref SM.empty

	val seen_structs = ref SS.empty
	val seen_unions = ref SS.empty

	val nexttag = ref 0
	val tags = Tidtab.uidtab () : (string * bool) Tidtab.uidtab

	fun mk_context_td tdname =
	    let val next = ref 0
	    in
		CONTEXT
		    { gensym =
		      fn () => let
			     val n = !next
			 in
			     next := n + 1;
			     concat ["'",
				     if n = 0 then "" else Int.toString n,
				     tdname]
			 end,
		      anon = false }
	    end

	fun mk_context_su (parent_tag, anon) =
	    let val next = ref 0
	    in
		CONTEXT { gensym =
			  fn () => let
				 val n = !next
			     in
				 next := n + 1;
				 concat [parent_tag, "'", Int.toString n]
			     end,
			  anon = anon }
	    end

	val tl_context =
	    let val next = ref 0
	    in
		CONTEXT { gensym =
			  fn () => let
				 val n = !next
			     in
				 next := n + 1;
				 Int.toString n
			     end,
			  anon = true }
	    end

	fun tagname (SOME t, _, _) = (t, false)
	  | tagname (NONE, CONTEXT { gensym, anon }, tid) =
	    (case Tidtab.find (tags, tid) of
		 SOME ta => ta
	       | NONE => let
		     val t = gensym ()
		 in
		     Tidtab.insert (tags, tid, (t, anon));
		     (t, anon)
		 end)

	fun reported_tagname (t, false) = t
	  | reported_tagname (t, true) = t ^ gensym_suffix

	fun valty C A.Void = raise VoidType
	  | valty C A.Ellipses = raise Ellipsis
	  | valty C (A.Qual (q, t)) = valty C t
	  | valty C (A.Numeric (_, _, A.SIGNED, A.CHAR, _)) = Spec.SCHAR
	  | valty C (A.Numeric (_, _, A.UNSIGNED, A.CHAR, _)) = Spec.UCHAR
	  | valty C (A.Numeric (_, _, A.SIGNED, A.INT, _)) = Spec.SINT
	  | valty C (A.Numeric (_, _, A.UNSIGNED, A.INT, _)) = Spec.UINT
	  | valty C (A.Numeric (_, _, A.SIGNED, A.SHORT, _)) = Spec.SSHORT
	  | valty C (A.Numeric (_, _, A.UNSIGNED, A.SHORT, _)) = Spec.USHORT
	  | valty C (A.Numeric (_, _, A.SIGNED, A.LONG, _)) = Spec.SLONG
	  | valty C (A.Numeric (_, _, A.UNSIGNED, A.LONG, _)) = Spec.ULONG
	  | valty C (A.Numeric (_, _, _, A.FLOAT, _)) = Spec.FLOAT
	  | valty C (A.Numeric (_, _, _, A.DOUBLE, _)) = Spec.DOUBLE
	  | valty C (A.Numeric (_, _, A.SIGNED, A.LONGLONG, _)) =
	      Spec.SLONGLONG
	  | valty C (A.Numeric (_, _, A.UNSIGNED, A.LONGLONG, _)) =
	      Spec.ULONGLONG
	  | valty C (A.Numeric (_, _, _, A.LONGDOUBLE, _)) =
	      Spec.UNIMPLEMENTED "long double"
	  | valty C (A.Array (NONE, t)) = valty C (A.Pointer t)
	  | valty C (A.Array (SOME (n, _), t)) =
	    let val d = Int.fromLarge n
	    in
		if d < 0 then err "negative dimension"
		else Spec.ARR { t = valty C t, d = d, esz = sizeOf t }
	    end
	  | valty C (A.Pointer t) =
	    (case getCoreType t of
		 A.Void => Spec.VOIDPTR
	       | A.Function f => fptrty C f
	       | _ => Spec.PTR (cobj C t))
	  | valty C (A.Function f) = fptrty C f
	  | valty C (A.StructRef tid) = typeref (tid, Spec.STRUCT, C)
	  | valty C (A.UnionRef tid) = typeref (tid, Spec.UNION, C)
	  | valty C (A.EnumRef tid) = typeref (tid, fn t => Spec.ENUM (t, false), C)
	  | valty C (A.TypeRef tid) =
	    typeref (tid, fn _ => bug "missing typedef info", C)
	  | valty C A.Error = err "Error type"

	and valty_nonvoid C t = valty C t
	    handle VoidType => err "void variable type"

	and typeref (tid, otherwise, C) =
	    case Tidtab.find (tidtab, tid) of
		NONE => bug "tid not bound in tidtab"
	      | SOME { name = SOME n, ntype = NONE, ... } => otherwise n
	      | SOME { name = NONE, ntype = NONE, ... } =>
		bug "both name and ntype missing in tidtab binding"
	      | SOME { name, ntype = SOME nct, location, ... } =>
		(case nct of
		     B.Struct (tid, members) =>
		     structty (tid, name, C, members, location)
		   | B.Union (tid, members) =>
		     unionty (tid, name, C, members, location)
		   | B.Enum (tid, edefs) =>
		     enumty (tid, name, C, edefs, location)
		   | B.Typedef (_, t) => let
			 val n =
			     case name of
				 NONE => bug "missing name in typedef"
			       | SOME n => n
			 val C' = mk_context_td n
			 val res = valty C' t
			 fun sameName { src, name, spec } = name = n
		     in
			 if includedTy (n, location) andalso
			    not (SM.inDomain (!gtys, n)) then
			     gtys := SM.insert (!gtys, n,
						{ src = srcOf location,
						  name = n, spec = res })
			 else ();
			 res
		     end)

	and enumty (tid, name, C, edefs, location) = let
	    val (tag_stem, anon) = tagname (name, C, tid)
	    val tag = reported_tagname (tag_stem, anon)
	    fun one ({ name, uid, location, ctype, kind }, i) =
		{ name = Symbol.name name, spec = i }
	    val enums = if anon then anon_enums else named_enums
	in
	    enums := SM.insert (!enums, tag,
				{ src = srcOf location,
				  tag = tag,
				  anon = anon,
				  descr = tag,
				  exclude = not (includedEnum (tag, location)),
				  spec = map one edefs });
	    Spec.ENUM (tag, anon)
	end

	and structty (tid, name, C, members, location) = let
	    val (tag_stem, anon) = tagname (name, C, tid)
	    val tag = reported_tagname (tag_stem, anon)
	    val ty = Spec.STRUCT tag
	    val C' = mk_context_su (tag_stem, anon)
	in
	    if SS.member (!seen_structs, tag) then ()
	    else let
		    val _ = seen_structs := SS.add (!seen_structs, tag)

		    val fol = fieldOffsets (A.StructRef tid)
		    val ssize = sizeOf (A.StructRef tid)

		    fun bfspec (offset, bits, shift, (c, t)) = let
			val offset = offset
			val bits = Word.fromLargeInt bits
			val shift = eshift (shift, intbits, bits)
			val r = { offset = offset,
				  constness = c,
				  bits = bits,
				  shift = shift }
		    in
			case t of
			    Spec.UINT => Spec.UBF r
			  | Spec.SINT => Spec.SBF r
			  | _ => err "non-int bitfield"
		    end

		    fun synthetic (synth, (_, false), _) = ([], synth)
		      | synthetic (synth, (endp, true), startp) =
			if endp = startp then ([], synth)
			else ([{ name = Int.toString synth,
				 spec = Spec.OFIELD
					{ offset = endp,
					  spec = (Spec.RW,
						  Spec.ARR { t = Spec.UCHAR,
							     d = startp - endp,
							     esz = 1 }),
					  synthetic = true } }],
			      synth+1)

		    fun build ([], synth, gap) =
			#1 (synthetic (synth, gap, ssize))
		      | build ((t, SOME m, NONE) :: rest, synth, gap) =
			let val bitoff = #bitOffset (getField (m, fol))
			    val bytoff = bitoff div bytebits
			    val (filler, synth) =
				synthetic (synth, gap, bytoff)
			    val endp = bytoff + sizeOf t
			in
			    if bitoff mod bytebits <> 0 then
				bug "non-bitfield not on byte boundary"
			    else
				filler @
				{ name = Symbol.name (#name m),
				  spec = Spec.OFIELD
					     { offset = bytoff,
					       spec = cobj C' t,
					       synthetic = false } } ::
				build (rest, synth, (endp, false))
			end
		      | build ((t, SOME m, SOME b) :: rest, synth, gap) =
			let val bitoff = #bitOffset (getField (m, fol))
			    val bytoff =
				(intalign * (bitoff div intalign))
				div bytebits
			    val gap = (#1 gap, true)
			in
			    { name = Symbol.name (#name m),
			      spec = bfspec (bytoff, b,
					     bitoff mod intalign,
					     cobj C' t) } ::
			    build (rest, synth, gap)
			end
		      | build ((t, NONE, SOME _) :: rest, synth, gap) =
			build (rest, synth, (#1 gap, true))
		      | build ((_, NONE, NONE) :: _, _, _) =
			bug "unnamed struct member (not bitfield)"

		    val fields = build (members, 0, (0, false))
		in
		    structs := { src = srcOf location,
				 tag = tag, 
				 anon = anon,
				 size = Word.fromInt ssize,
				 exclude = not (includedSU (tag, location)),
				 fields = fields } :: !structs
		end;
	    ty
	end

	and unionty (tid, name, C, members, location) = let
	    val (tag_stem, anon) = tagname (name, C, tid)
	    val tag = reported_tagname (tag_stem, anon)     
	    val C' = mk_context_su (tag_stem, anon)
	    val ty = Spec.UNION tag
	    val lsz = ref 0
	    fun mkField (t, m: A.member) = let
		val sz = sizeOf t
	    in
		{ name = Symbol.name (#name m),
		  spec = Spec.OFIELD { offset = 0,
				       spec = cobj C' t,
				       synthetic = false } }
	    end
	in
	    if SS.member (!seen_unions, tag) then ()
	    else let
		    val _ = seen_unions := SS.add (!seen_unions, tag)
		    val all = map mkField members
		in
		    unions := { src = srcOf location,
				tag = tag,
				anon = anon,
				size = Word.fromInt (sizeOf (A.UnionRef tid)),
				exclude = not (includedSU (tag, location)),
				all = all } :: !unions
		end;
	    ty
	end

	and cobj C t = (constness t, valty_nonvoid C t)

	and fptrty C f = Spec.FPTR (cft C f)

	and cft C (res, args) =
	    { res = case getCoreType res of
			A.Void => NONE
		      | _ => SOME (valty_nonvoid C res),
	      args = case args of
			 [(arg, _)] => (case getCoreType arg of
				       A.Void => []
				     | _ => [valty_nonvoid C arg])
		       | _ => let fun build [] = []
				    | build [(x, _)] =
				      ([valty_nonvoid C x]
				       handle Ellipsis =>
					      (warnLoc
						   ("varargs not supported; \
						    \ignoring the ellipsis\n");
						   []))
				    | build ((x, _) :: xs) =
				      valty_nonvoid C x :: build xs
			      in
				  build args
			      end }

	fun ft_argnames (res, args) =
	    let val optids = map (fn (_, optid) => optid) args
	    in
		if List.exists (not o isSome) optids then NONE
		else SOME (map valOf optids)
	    end

	fun functionName (f: A.id, ailo: A.id list option) = let
	    val n = Symbol.name (#name f)
	    val anlo = Option.map (map (Symbol.name o #name)) ailo
	in
	    if n = "_init" orelse n = "_fini" orelse
	       SM.inDomain (!gfuns, n) then ()
	    else case #stClass f of
		     (A.EXTERN | A.DEFAULT) =>
		     (case getFunction (#ctype f) of
			  SOME fs =>
			  gfuns := SM.insert (!gfuns, n,
					      { src = !curLoc,
						name = n,
						spec = cft tl_context fs,
						argnames = anlo })
			| NONE => bug "function without function type")
		   | (A.AUTO | A.REGISTER | A.STATIC) => ()
	end

	fun varDecl (v: A.id) =
	    case #stClass v of
		(A.EXTERN | A.DEFAULT) =>
		(case getFunction (#ctype v) of
		     SOME fs => if realFunctionDefComing (#name v) then ()
				else functionName (v, ft_argnames fs)
		   | NONE =>
		     let val n = Symbol.name (#name v)
		     in
			 if SM.inDomain (!gvars, n) then ()
			 else gvars := SM.insert
					   (!gvars, n,
					    { src = !curLoc, name = n,
					      spec = cobj tl_context
							  (#ctype v) })
		     end)
	      | (A.AUTO | A.REGISTER | A.STATIC) => ()

	fun dotid tid =
	    (* Spec.SINT is an arbitrary choice; the value gets
	     * ignored anyway *)
	    (ignore (typeref (tid, fn _ => Spec.SINT, tl_context))
	     handle VoidType => ())	(* ignore type aliases for void *)

	fun declaration (A.TypeDecl { tid, ... }) = dotid tid
	  | declaration (A.VarDecl (v, _)) = varDecl v

	fun coreExternalDecl (A.ExternalDecl d) = declaration d
	  | coreExternalDecl (A.FunctionDef (f, argids, _)) =
	    functionName (f, SOME argids)
	  | coreExternalDecl (A.ExternalDeclExt _) = ()

	fun externalDecl (A.DECL (d, _, l)) =
	    if isThisFile l then (curLoc := SourceMap.locToString l;
				  coreExternalDecl d)
	    else ()

	fun doast l = app externalDecl l

	fun gen_enums () = let
	    val ael = SM.listItems (!anon_enums)
	    val nel = SM.listItems (!named_enums)
	    infix $
	    fun x $ [] = [x]
	      | x $ y = x :: ", " :: y
	    fun onev (v as { name, spec }, m) =
		if SM.inDomain (m, name) then raise Duplicate name
		else SM.insert (m, name, v)
	    fun onee ({ src, tag, anon, spec, descr, exclude }, (m, sl)) =
		(foldl onev m spec, src $ sl)
	in
	    if collect_enums then
		let val (m, sl) = foldl onee (SM.empty, []) ael
		in
		    if SM.isEmpty m then nel
		    else { src = concat (rev sl),
			   tag = "'",
			   anon = false,
			   descr = "collected from unnamed enumerations",
			   exclude = false,
			   spec = SM.listItems m }
			 :: nel
		end handle Duplicate name =>
			   (warn (concat ["constant ", name,
					  " defined more than once;\
					  \ disabling `-collect'\n"]);
			    ael @ nel)
	    else ael @ nel
	end
    in
	doast ast;
	app (dotid o #1) (Tidtab.listItemsi tidtab);
	{ structs = !structs,
	  unions = !unions,
	  gtys = SM.listItems (!gtys),
	  gvars = SM.listItems (!gvars),
	  gfuns = SM.listItems (!gfuns),
	  enums = gen_enums () } : Spec.spec
    end
end
