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

SCM Repository

[sml3d] View of /trunk/sml3d/gen/spec-parser/db.sml
ViewVC logotype

View of /trunk/sml3d/gen/spec-parser/db.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1228 - (download) (annotate)
Mon Aug 8 12:28:32 2011 UTC (6 years, 4 months ago) by jhr
File size: 12244 byte(s)
  Working on spec parser/database
(* db.sml
 *
 * COPYRIGHT (c) 2011 The SML3d Project (http://sml3d.cs.uchicago.edu)
 * All rights reserved.
 *)

structure DB : sig

    type db

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

  (* create a new empty database by cloning the meta information from another database *)
    val clone : db -> db

  (* 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 = XMLRep
    structure ATbl = AtomTable
    structure AMap = AtomMap
    structure ASet = AtomSet

    datatype db = DB of {
        typemap : string,
        enums : string,
        functs : string,
        constprefix : string,
        functprefix : 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{
            typemap = #typemap content,
            enums = #enums content,
            functs = #functs content,
            constprefix = #constprefix content,
            functprefix = #functprefix 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{
                typemap = #typemap content,
                enums = #enums content,
                functs = #functs content,
                constprefix = #constprefix content,
                functprefix = #functprefix 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{
            typemap = #typemap content,
            enums = #enums content,
            functs = #functs content,
            constprefix = #constprefix content,
            functprefix = #functprefix 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 tm = Typemap.load (#typemap content)
              val enums = Enums.load (#enums content)
              val functs = Functs.load (#functs content, tm)
            (* 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 *)
(* FIXME: we are discarding a lot of info from the spec files; perhaps we should change the XMLRep
 * types to more closely match the Enums, Typemap, etc. modules?
 *)
              fun insEnum (Enums.Enum{name, kind, consts}) = let
                    fun cvtConst (name, v) = {
                            name = name,
                            value = (case v
                               of Enums.HEX s => s
                                | Enums.DEC s => s
                                | Enums.SYM s => s
                              (* end case *))
                          }
                    in
                      insConst (name, X.ConstGrp{
                          name = name,
                          kind = (case kind
                             of Enums.DEFINE => SpecNames.defineAtom
                              | Enums.ENUM => SpecNames.enumAtom
                              | Enums.MASK => SpecNames.maskAtom
                            (* 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 not(Atom.same(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} = (case AMap.find(cMap, name)
                                 of NONE => true
                                  | SOME c => if (value <> #value c)
                                      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

  (* 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 set of the base functions *)
                      val fSet = List.foldl
                            (fn (X.Fun{name, ...}, s) => ASet.add(s, name))
                              ASet.empty
                                baseFuns
                      fun match (X.Fun{name, ...}) = ASet.member(fSet, name)
                      in
                        case List.filter match functs
                         of [] => ()
                          | fs => insertInBase (catName, X.Category{
                                name = catName,
                                functs = baseFuns @ fs
                              })
                        (* end case *)
                      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) = let
          in
          (* check that the two databases are compatible *)
            if (#typemap base <> #typemap ext)
            orelse (#enums base <> #enums ext)
            orelse (#functs base <> #functs base)
            orelse (#constprefix base <> #constprefix ext)
            orelse (#functprefix base <> #functprefix ext)
              then raise (Fail "database metadata mismatch")
              else ();
          (* extend the database tables *)
            extendConstants (#constants base, #constants ext);
            extendTypes (#types base, #types ext);
            extendFuncts (#functions base, #functions ext)
          end

  end

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