Home My Page Projects Code Snippets Project Openings 3D graphics for Standard ML
Summary Activity SCM

SCM Repository

[sml3d] View of /trunk/sml3d/gen/gen-from-xml/gldb/db.sml
ViewVC logotype

View of /trunk/sml3d/gen/gen-from-xml/gldb/db.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1373 - (download) (annotate)
Wed Apr 2 17:27:12 2014 UTC (5 years ago) by jhr
File size: 15536 byte(s)
  working on generation tools
(* db.sml
 *
 * COPYRIGHT (c) 2014 The SML3d Project (http://sml3d.cs.uchicago.edu)
 * All rights reserved.
 *
 * We should use the SpecLoader.registry representation for the database.  Perhaps it will
 * need to be made closer to the DBXML representation, but there is no reason for yet another
 * representation of basically the same information!
 *)

structure DB : sig

    type db

    val toXML : db -> XMLRep.db
    val fromXML : XMLRep.db -> db

  (* create a database from a Khronos XML specification file *)
    val fromGLSpec : SpecLoader.registry -> db

(* NOTE: probably don't need this function *)
  (* create a new empty database by cloning the meta information from another database *)
    val clone : db -> db

(* NOTE: probably don't need this function *)
  (* load the specifications for the database into the database.  If the database is not
   * empty, then the Fail exception is raised.
   *)
    val load : db -> unit

  (* extend the first database with any additional definitions, etc. that are provided by
   * the second database.
   *)
    val extend : db * db -> unit

  end = struct

    structure X = DBXMLRep
    structure Rep = SpecRep	(* Khronos specification file representation *)
    structure ATbl = AtomTable
    structure AMap = AtomMap
    structure ASet = AtomSet

    datatype db = DB of {
        registry : string,       	(* specification file pathname *)
	api : string,
	profile : string,
	extensions : string,
        constants : X.const_grp ATbl.hash_table,
        types : X.ty ATbl.hash_table,
        functions : X.category ATbl.hash_table
      }

  (* check to see if a database is empty *)
    fun isEmpty (DB{constants, types, functions, ...}) =
          (ATbl.numItems constants = 0) andalso (ATbl.numItems types = 0)
            andalso (ATbl.numItems functions = 0)

  (* comparison function on atoms that we can use with ListMergeSort.sort to sort in ascending
   * lexical order.
   *)
    fun atomGT (a, b) = (case Atom.lexCompare(a, b)
           of GREATER => true
            | _ => false
          (* end case *))

    fun sortTableItems tbl = let
          fun gt ((key1, _), (key2, _)) = atomGT(key1, key2)
          in
            List.map #2 (ListMergeSort.sort gt (ATbl.listItemsi tbl))
          end

  (* sort constant groups by name *)
    local
      fun gt (X.ConstGrp{name=a, ...}, X.ConstGrp{name=b, ...}) = atomGT (a, b)
    in
    val sortConstGrps = ListMergeSort.sort gt
    end

    fun toXML (DB content) = X.DB{
            specfile = #specfile content,
            constants = sortTableItems(#constants content),
            types = sortTableItems(#types content),
            functions = sortTableItems(#functions content)
          }

    fun fromXML (X.DB content) = let
          val constants = ATbl.mkTable (List.length(#constants content), Fail "constants")
          val insConst = ATbl.insert constants
          val types = ATbl.mkTable (List.length(#types content), Fail "types")
          val insTy = ATbl.insert types
          val functions = ATbl.mkTable (List.length(#functions content), Fail "functions")
          val insFn = ATbl.insert functions
          in
          (* initialize tables *)
            List.app (fn (cg as X.ConstGrp{name, ...}) => insConst(name, cg)) (#constants content);
            List.app (fn (ty as {name, def}) => insTy(name, ty)) (#types content);
            DB{
                specfile = #specfile content,
                constants = constants,
                types = types,
                functions = functions
              }
          end

  (* create a new empty database by cloning the meta information from another database *)
    fun clone (DB content) = DB{
            specfile = #specfile content,
            constants = ATbl.mkTable (ATbl.numItems(#constants content), Fail "constants"),
            types = ATbl.mkTable (ATbl.numItems(#types content), Fail "types"),
            functions = ATbl.mkTable (ATbl.numItems(#functions content), Fail "functions")
          }

  (* load the specifications for the database into the database.  If the database is not
   * empty, then the Fail exception is raised.
   *)
    fun load (db as DB content) = if (isEmpty db)
          then let
            (* load and check specification *)
	      val spec = SpecParser (#specfile db)
            (* insertion functions for database tables *)
              val insConst = ATbl.insert (#constants content)
              val insTy = ATbl.insert (#types content)
              val insCat = ATbl.insert (#functions content)
              val findCat = ATbl.find (#functions content)
            (* insert an enum definition *)
              fun insEnum (Enums.Enum{name, kind, consts}) = let
                    fun cvtConst (name, v, from) = {
                            name = name,
                            value = (case v
                               of Enums.HEX s => s
                                | Enums.DEC s => s
                                | Enums.SYM s => s
                              (* end case *)),
                            from = from
                          }
                    in
                      insConst (name, X.ConstGrp{
                          name = name,
                          kind = (case kind
                             of Enums.DEFINE => X.DEFINE
                              | Enums.ENUM => X.ENUM
                              | Enums.MASK => X.MASK
                            (* end case *)),
                          consts = List.map cvtConst consts
                        })
                    end
              (* insert the functions from a category *)
              fun insCategory (cat, fs) = let
                    fun cvtParam (Functs.Param{name, ty, dir, xferTy}) = X.Param{
                            name = name,
                            cty = ty,
                            mlty = NONE (* FIXME *)
                          }
                    fun cvtFunct (Functs.Fun content) = X.Fun{
                            name = #name content,
                            alias = NONE, (* no aliases in spec files *)
                            version = #version content,
                            deprecated = #deprecated content,
                            retTy = {
                                cty = #returnTy content,
                                mlty = NONE (* FIXME *)
                              },
                            params = List.map cvtParam (#params content)
                          }
                    in
                      case (cat, fs)
                       of (NONE, []) => ()
                        | (NONE, _) => raise Fail "default category"
                        | (SOME cat, _) =>
                            insCat (cat, X.Category{name = cat, functs = List.map cvtFunct fs})
                      (* end case *)
                    end
              in
                Enums.app insEnum enums;
                Functs.appByCategory insCategory functs
              end
          else raise Fail "load on non-empty database"

    fun conflict msg = raise Fail(concat msg)

 (* extend the constant table base by the constants in ext *)
    fun extendConstants (base, ext) = let
          val findInBase = ATbl.find base
          val insertInBase = ATbl.insert base
          fun extend (grp as X.ConstGrp{name=grpName, kind, consts}) = (
                case findInBase grpName
                 of SOME(X.ConstGrp{kind=k, consts=baseConsts, ...}) =>
                      if (kind <> k)
                        then conflict[
                            "constant group ", Atom.toString grpName, " kind conflict"
                          ]
                        else let
                        (* construct a mapping for the base constants *)
                          val cMap = List.foldl
                                (fn (c, m) => AMap.insert(m, #name c, c))
                                  AMap.empty
                                    baseConsts
                          fun match {name, value, from} = (case AMap.find(cMap, name)
                                 of NONE => true
                                  | SOME c => if (value <> #value c)
                                      andalso (case (from, #from c)
                                         of (NONE, NONE) => true
                                          | (SOME a, SOME b) => Atom.same(a, b)
                                          | _ => false)
                                      then conflict[
                                          "constant ", Atom.toString grpName,
                                          " ", Atom.toString name, " value conflict"
                                        ]
                                      else false
                                (* end case *))
                          in
                            case List.filter match consts
                             of [] => ()
                              | cs => insertInBase (grpName, X.ConstGrp{
                                    name = grpName,
                                    kind = kind,
                                    consts = baseConsts @ cs
                                  })
                            (* end case *)
                          end
                  | NONE => (* add the group to the base *)
                      insertInBase (grpName, grp)
                (* end case *))
          in
            ATbl.app extend ext
          end

 (* extend the type table by the constants in ext *)
    fun extendTypes (base, ext) = let
          val findInBase = ATbl.find base
          val insertInBase = ATbl.insert base
          fun extend (ty as {name, def}) = (case findInBase name
                 of SOME ty' => if CType.same(def, #def ty')
                      then conflict[
                          "type ", Atom.toString name, " definition conflict"
                        ]
                      else ()
                  | NONE => insertInBase (name, ty)
                (* end case *))
          in
            ATbl.app extend ext
          end

  (* construct a finite map from a list of functions *)
    fun mkFunMap fns = let
          fun ins (f as X.Fun{name, ...}, m) = AMap.insert(m, name, f)
          in
            List.foldl ins AMap.empty fns
          end

  (* extend the function table by the definitions in ext *)
    fun extendFuncts (base, ext) = let
          val findInBase = ATbl.find base
          val insertInBase = ATbl.insert base
          fun extend (cat as X.Category{name=catName, functs}) = (
                case findInBase catName
                 of SOME(X.Category{functs=baseFuns, ...}) => let
                    (* construct a map of the base functions *)
                      val baseMap = mkFunMap baseFuns
                      fun inBase (X.Fun{name, ...}) = AMap.inDomain(baseMap, name)
                    (* partition the extension functions into those that are possible updates
                     * of the functions in the base and those that are new.
                     *)
                      val (updateFns, newFns) = let
                            val (ufs, nfs) = List.partition inBase functs
                            val uMap = mkFunMap ufs
                            in
                              (uMap, nfs)
                            end
                    (* merge a base and extension version of an optional field *)
                      fun merge (name, fld, base, ext) = (case (base, ext)
                             of (NONE, _) => ext
                              | (SOME _, NONE) => base
                              | (SOME v1, SOME v2) =>
                                  if (v1 <> v2)
                                    then conflict[
                                        "function ", Atom.toString name, ": ",
                                        fld, " field has conflicting values"
                                      ]
                                    else ext
                            (* end case *))
                    (* check to see if a base function's definition is modified
                     * by the version in the extension.  We also make sure that alias
                     * functions are consistent with the canonical definition.
                     *)
                      fun update (baseFn as X.Fun{
                              name, alias=NONE, version, deprecated, retTy, params
                            }) = (case AMap.find (updateFns, name)
                             of NONE => baseFn
                              | SOME(X.Fun info) => let
                                  val version = merge (name, "version", version, #version info)
                                  val deprecated = merge (name, "deprecated", deprecated, #deprecated info)
                                  in
                                    X.Fun{
                                        name = name, version = version,
                                        alias = NONE,
                                        deprecated = deprecated,
                                        retTy = retTy,
                                        params = params
                                      }
                                  end
                          (* end case *))
                        | update (baseFn as X.Fun{
                              name, alias=SOME name', version, deprecated, retTy, params
                            }) = (case AMap.find (updateFns, name')
                             of NONE => baseFn
                              | SOME(X.Fun info) => let
                                (* want the alias to be consistent with the canonical version *)
                                  val version = merge (name, "version", version, #version info)
                                  val deprecated = merge (name, "deprecated", deprecated, #deprecated info)
                                  in
                                    X.Fun{
                                        name = name, version = version,
                                        alias = SOME name',
                                        deprecated = deprecated,
                                        retTy = retTy,
                                        params = params
                                      }
                                  end
                          (* end case *))
                      in
                        insertInBase (catName, X.Category{
                            name = catName,
                            functs = (List.map update baseFuns) @ newFns
                          })
                      end
                  | NONE => insertInBase (catName, cat)
                (* end case *))
          in
            ATbl.app extend ext
          end

  (* extend the first database with any additional definitions, etc. that
   * are provided by the second database.
   *)
    fun extend (DB base, DB ext) = (
(* NOTE: maybe we should allow different spec files? *)
        (* check that the two databases are compatible *)
          if (#specfile base <> #specfile ext)
            then conflict["spec files do not match"]
            else ();
        (* extend the database tables *)
          extendConstants (#constants base, #constants ext);
          extendTypes (#types base, #types ext);
          extendFuncts (#functions base, #functions ext))

  end

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