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 1223 - (download) (annotate)
Wed Aug 3 18:28:46 2011 UTC (7 years, 2 months ago) by jhr
File size: 5765 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

  end = struct

    structure X = XMLRep
    structure ATbl = AtomTable

    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 insFn = ATbl.insert (#functions content)
            (* insert an enum definition *)
(* FIXME: we are losing 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
              in
                Enums.app insEnum enums;
()
              end
          else raise Fail "load on non-empty database"

  end

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