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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1376, Wed Apr 2 17:51:39 2014 UTC revision 1377, Fri Apr 4 20:45:22 2014 UTC
# Line 12  Line 12 
12    
13      type db      type db
14    
15      val toXML : db -> XMLRep.db      val toXML : db -> DBXMLRep.db
16      val fromXML : XMLRep.db -> db      val fromXML : DBXMLRep.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  
17    
18  (* NOTE: probably don't need this function *)  (* NOTE: probably don't need this function *)
19    (* load the specifications for the database into the database.  If the database is not    (* load the specifications for the database into the database.  If the database is not
20     * empty, then the Fail exception is raised.     * empty, then the Fail exception is raised.
21     *)     *)
22      val load : db -> unit      val load : {
23              regFile : string,
24              api : string,         (* api to filter the registry *)
25              profile : string,     (* profile to filter the registry *)
26              extensions : string   (* string that is matched against "supported" attribute *)
27            } -> db
28    
29    (* extend the first database with any additional definitions, etc. that are provided by    (* extend the first database with any additional definitions, etc. that are provided by
30     * the second database.     * the second database.
# Line 36  Line 34 
34    end = struct    end = struct
35    
36      structure X = DBXMLRep      structure X = DBXMLRep
     structure Rep = SpecRep     (* Khronos specification file representation *)  
37      structure ATbl = AtomTable      structure ATbl = AtomTable
38      structure AMap = AtomMap      structure AMap = AtomMap
39      structure ASet = AtomSet      structure ASet = AtomSet
# Line 46  Line 43 
43          api : string,          api : string,
44          profile : string,          profile : string,
45          extensions : string,          extensions : string,
46          constants : X.const_grp ATbl.hash_table,          types : X.ty AtomTable.hash_table,
47          types : X.ty ATbl.hash_table,          enums : X.enum AtomTable.hash_table,
48          functions : X.category ATbl.hash_table          groups : X.enum_grp AtomTable.hash_table,
49            commands : X.cmd AtomTable.hash_table,
50            features : X.feature AtomTable.hash_table
51        }        }
52    
53    (* check to see if a database is empty *)    (* check to see if a database is empty *)
54      fun isEmpty (DB{constants, types, functions, ...}) =      fun isEmpty (DB{types, enums, commands, ...}) =
55            (ATbl.numItems constants = 0) andalso (ATbl.numItems types = 0)            (ATbl.numItems types = 0) andalso (ATbl.numItems enums = 0)
56              andalso (ATbl.numItems functions = 0)              andalso (ATbl.numItems commands = 0)
57    
58    (* comparison function on atoms that we can use with ListMergeSort.sort to sort in ascending    (* comparison function on atoms that we can use with ListMergeSort.sort to sort in ascending
59     * lexical order.     * lexical order.
# Line 70  Line 69 
69              List.map #2 (ListMergeSort.sort gt (ATbl.listItemsi tbl))              List.map #2 (ListMergeSort.sort gt (ATbl.listItemsi tbl))
70            end            end
71    
   (* 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  
   
72      fun toXML (DB content) = X.DB{      fun toXML (DB content) = X.DB{
73              specfile = #specfile content,              registry = #registry content,
74              constants = sortTableItems(#constants content),              api = #api content,
75                profile = #profile content,
76                extensions = #extensions content,
77              types = sortTableItems(#types content),              types = sortTableItems(#types content),
78              functions = sortTableItems(#functions content)              enums = sortTableItems(#enums content),
79                commands = sortTableItems(#commands content),
80                groups = sortTableItems(#groups content),
81                features = sortTableItems(#features content)
82            }            }
83    
84      fun fromXML (X.DB content) = let      fun fromXML (X.DB content) = let
85            val constants = ATbl.mkTable (List.length(#constants content), Fail "constants")            val enums = ATbl.mkTable (List.length(#enums content), Fail "enums")
86            val insConst = ATbl.insert constants            val insEnum = ATbl.insert enums
87            val types = ATbl.mkTable (List.length(#types content), Fail "types")            val types = ATbl.mkTable (List.length(#types content), Fail "types")
88            val insTy = ATbl.insert types            val insTy = ATbl.insert types
89            val functions = ATbl.mkTable (List.length(#functions content), Fail "functions")            val commands = ATbl.mkTable (List.length(#commands content), Fail "functions")
90            val insFn = ATbl.insert functions            val insCmd = ATbl.insert commands
91              val groups = ATbl.mkTable (List.length(#groups content), Fail "groups")
92              val insGrp = ATbl.insert groups
93              val features = ATbl.mkTable (List.length(#features content), Fail "features")
94              val insFeature = ATbl.insert features
95            in            in
96            (* initialize tables *)            (* initialize tables *)
             List.app (fn (cg as X.ConstGrp{name, ...}) => insConst(name, cg)) (#constants content);  
97              List.app (fn (ty as {name, def}) => insTy(name, ty)) (#types content);              List.app (fn (ty as {name, def}) => insTy(name, ty)) (#types content);
98                List.app (fn (enum as {name, ty, value}) => insEnum(name, enum)) (#enums content);
99                List.app (fn (cmd as X.Cmd{name, ...}) => insCmd(name, cmd)) (#commands content);
100                List.app (fn (grp as X.EnumGrp{name, ...}) => insGrp(name, grp)) (#groups content);
101                List.app (fn (f as X.Feature{name, ...}) => insFeature(name, f)) (#features content);
102              DB{              DB{
103                  specfile = #specfile content,                  registry = #registry content,
104                  constants = constants,                  api = #api content,
105                    profile = #profile content,
106                    extensions = #extensions content,
107                  types = types,                  types = types,
108                  functions = functions                  enums = enums,
109                    commands = commands,
110                    groups = groups,
111                    features = features
112                }                }
113            end            end
114    
115    (* obsolete
116    (* create a new empty database by cloning the meta information from another database *)    (* create a new empty database by cloning the meta information from another database *)
117      fun clone (DB content) = DB{      fun clone (DB content) = DB{
118              specfile = #specfile content,              registry = #registry content,
119              constants = ATbl.mkTable (ATbl.numItems(#constants content), Fail "constants"),              api = #api content,
120                profile = #profile content,
121                extensions = #extensions content,
122              types = ATbl.mkTable (ATbl.numItems(#types content), Fail "types"),              types = ATbl.mkTable (ATbl.numItems(#types content), Fail "types"),
123              functions = ATbl.mkTable (ATbl.numItems(#functions content), Fail "functions")              enums = ATbl.mkTable (ATbl.numItems(#enums content), Fail "enums"),
124                commands = ATbl.mkTable (ATbl.numItems(#commands content), Fail "commands"),
125                groups = ATbl.mkTable (ATbl.numItems(#groups content), Fail "groups"),
126                features = ATbl.mkTable (ATbl.numItems(#features content), Fail "features")
127            }            }
   
   (* load the specifications for the database into the database.  If the database is not  
    * empty, then the Fail exception is raised.  
128     *)     *)
129      fun load (db as DB content) = if (isEmpty db)  
130            then let    (* load the specifications for the database into the database. *)
131        fun load {regFile, api, profile, extensions} = let
132              (* load and check specification *)              (* load and check specification *)
133                val spec = SpecParser (#specfile db)            val registry = SpecLoader.load{
134              (* insertion functions for database tables *)                    regFile = regFile,
135                val insConst = ATbl.insert (#constants content)                    api = SOME api,
136                val insTy = ATbl.insert (#types content)                    profile = SOME profile,
137                val insCat = ATbl.insert (#functions content)                    extensions = SOME extensions
               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  
138                            }                            }
139                      in                      in
140                        insConst (name, X.ConstGrp{              DB{
141                            name = name,                  registry = regFile,
142                            kind = (case kind                  api = api,
143                               of Enums.DEFINE => X.DEFINE                  profile = profile,
144                                | Enums.ENUM => X.ENUM                  extensions = extensions,
145                                | Enums.MASK => X.MASK                  types = #types registry,
146                              (* end case *)),                  enums = #enums registry,
147                            consts = List.map cvtConst consts                  groups = #groups registry,
148                          })                  commands = #commands registry,
149                    features = let
150                      val tbl = ATbl.mkTable (List.length (#features registry), Fail "features")
151                      val ins = ATbl.insert tbl
152                      in
153                        List.app (fn (f as X.Feature{name, ...}) => ins(name, f)) (#features registry);
154                        tbl
155                      end                      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)  
156                            }                            }
157              end
158    
159        fun conflict msg = raise Fail(concat msg)
160    
161     (* extend the type table by the constants in ext *)
162        fun extendTypes (base, ext) = let
163              val findInBase = ATbl.find base
164              val insertInBase = ATbl.insert base
165              fun extend (ty as {name, def}) = (case findInBase name
166                     of SOME ty' => if CType.same(def, #def ty')
167                          then conflict[
168                              "type ", Atom.toString name, " definition conflict"
169                            ]
170                          else ()
171                      | NONE => insertInBase (name, ty)
172                    (* end case *))
173                      in                      in
174                        case (cat, fs)              ATbl.app extend ext
                        of (NONE, []) => ()  
                         | (NONE, _) => raise Fail "default category"  
                         | (SOME cat, _) =>  
                             insCat (cat, X.Category{name = cat, functs = List.map cvtFunct fs})  
                       (* end case *)  
175                      end                      end
176    
177     (* extend the enum table base by the enums in ext *)
178        fun extendEnums (base : X.enum AtomTable.hash_table, ext) = let
179              val findInBase = ATbl.find base
180              val insertInBase = ATbl.insert base
181              fun extend (enum as {name, ty, value}) = (case findInBase name
182                     of NONE => insertInBase(name, enum)
183                      | SOME{ty=ty', value=value', ...} => let
184                          val tyConflict = (case (ty, ty')
185                                 of (SOME ty, SOME ty') => not(CType.same(ty, ty'))
186                                  | (NONE, NONE) => false
187                                  | _ => true
188                                (* end case *))
189                in                in
190                  Enums.app insEnum enums;                          if tyConflict orelse (value <> value')
191                  Functs.appByCategory insCategory functs                            then conflict[
192                                  "enum ", Atom.toString name, " value conflict"
193                                ]
194                              else ()
195                          end
196                    (* end case *))
197              in
198    (* do we want to check for enums that have been removed? *)
199                ATbl.app extend ext
200                end                end
           else raise Fail "load on non-empty database"  
201    
202      fun conflict msg = raise Fail(concat msg)    (* extend the command table by the definitions in ext *)
203        fun extendCommands (base, ext) = let
204              val findInBase = ATbl.find base
205              val insertInBase = ATbl.insert base
206              fun extend (cmd as X.Cmd{name, protos}) = (
207                    case findInBase name
208                     of SOME(X.Cmd{protos=protos', ...}) => let
209                        (* we need to and any new prototypes into the existing list.  Note that for
210                         * the expected usage of the extend function, the "ext" table will not add
211                         * prototypes, just commands.
212                         *)
213                          val protoSet = let (* set of base prototypes *)
214                                fun ins (X.Proto{name, ...}, m) = ASet.add(m, name)
215                                in
216                                  List.foldl ins ASet.empty protos'
217                                end
218    (* NOTE: we may want to add a consistency check for the overlapping definitions! *)
219                          val newProtos = List.filter
220                                (fn (X.Proto{name, ...}) => not(ASet.member(protoSet, name)))
221                                  protos
222                          in
223                            if List.null newProtos
224                              then ()
225                              else insertInBase(name, X.Cmd{name=name, protos=protos' @ newProtos})
226                          end
227                      | NONE => insertInBase(name, cmd)
228                    (* end case *))
229              in
230                ATbl.app extend ext
231              end
232    
233   (* extend the constant table base by the constants in ext *)   (* extend the enum-group table base by the constants in ext *)
234      fun extendConstants (base, ext) = let      fun extendGroups (base, ext) = let
235            val findInBase = ATbl.find base            val findInBase = ATbl.find base
236            val insertInBase = ATbl.insert base            val insertInBase = ATbl.insert base
237            fun extend (grp as X.ConstGrp{name=grpName, kind, consts}) = (            fun extend (grp as X.EnumGrp{name=grpName, bitmask, consts}) = (
238                  case findInBase grpName                  case findInBase grpName
239                   of SOME(X.ConstGrp{kind=k, consts=baseConsts, ...}) =>                   of SOME(X.EnumGrp{bitmask=b, consts=baseConsts, ...}) =>
240                        if (kind <> k)                        if (bitmask <> b)
241                          then conflict[                          then conflict[
242                              "constant group ", Atom.toString grpName, " kind conflict"                              "enum group ", Atom.toString grpName, " bitmask conflict"
243                            ]                            ]
244                          else let                          else let
245                          (* construct a mapping for the base constants *)                          (* construct a set of the constants in base *)
246                            val cMap = List.foldl                            val cSet = ASet.fromList baseConsts
247                                  (fn (c, m) => AMap.insert(m, #name c, c))                            fun match name = not(ASet.member(cSet, name))
                                   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 *))  
248                            in                            in
249                              case List.filter match consts                              case List.filter match consts
250                               of [] => ()                               of [] => ()
251                                | cs => insertInBase (grpName, X.ConstGrp{                                | cs => insertInBase (grpName, X.EnumGrp{
252                                      name = grpName,                                      name = grpName,
253                                      kind = kind,                                      bitmask = bitmask,
254                                      consts = baseConsts @ cs                                      consts = baseConsts @ cs
255                                    })                                    })
256                              (* end case *)                              (* end case *)
# Line 226  Line 262 
262              ATbl.app extend ext              ATbl.app extend ext
263            end            end
264    
265   (* extend the type table by the constants in ext *)    (* extend the list of features base by the list ext *)
266      fun extendTypes (base, ext) = let      fun extendFeatures (base, ext) = let
267            val findInBase = ATbl.find base            val findInBase = ATbl.find base
268            val insertInBase = ATbl.insert base            val insertInBase = ATbl.insert base
269            fun extend (ty as {name, def}) = (case findInBase name          (* we extend the feature list by either extending a feature or by adding a new
270                   of SOME ty' => if CType.same(def, #def ty')           * feature to the list.
271                        then conflict[           *)
272                            "type ", Atom.toString name, " definition conflict"            fun extend (f as X.Feature{name, version, types, enums, commands}) = (
273                          ]                  case findInBase name
274                        else ()                   of SOME(X.Feature{version=v', types=tys', enums=enums', commands=cmds', ...}) => let
275                    | NONE => insertInBase (name, ty)                        fun extend' (base, ext) = let
276                  (* end case *))                              val set = AtomSet.fromList base
277            in            in
278              ATbl.app extend ext                                List.filter (fn x => not(AtomSet.member(set, x))) ext
279            end            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)  
280            in            in
281              List.foldl ins AMap.empty fns                          if (version <> v')
282                              then conflict["feature ", Atom.toString name, " has conflicting versions"]
283                              else ();
284                            case (extend'(types, tys'), extend'(enums, enums'), extend'(commands, cmds'))
285                             of ([], [], []) => () (* no change *)
286                              | (newTys, newEnums, newCmds) => insertInBase (name, X.Feature{
287                                    name = name, version = version,
288                                    types = types @ newTys,
289                                    enums = enums @ newEnums,
290                                    commands = commands @ newCmds
291                                  })
292                            (* end case *)
293                          end
294                      | NONE => insertInBase (name, f)
295                    (* end case *))
296              in
297                ATbl.app extend ext
298            end            end
299    
300    (* extend the function table by the definitions in ext *)  (*
     fun extendFuncts (base, ext) = let  
           val findInBase = ATbl.find base  
           val insertInBase = ATbl.insert base  
301            fun extend (cat as X.Category{name=catName, functs}) = (            fun extend (cat as X.Category{name=catName, functs}) = (
302                  case findInBase catName                  case findInBase catName
303                   of SOME(X.Category{functs=baseFuns, ...}) => let                   of SOME(X.Category{functs=baseFuns, ...}) => let
# Line 330  Line 375 
375            in            in
376              ATbl.app extend ext              ATbl.app extend ext
377            end            end
378    *)
379    
380    (* extend the first database with any additional definitions, etc. that    (* extend the first database with any additional definitions, etc. that
381     * are provided by the second database.     * are provided by the second database.
# Line 337  Line 383 
383      fun extend (DB base, DB ext) = (      fun extend (DB base, DB ext) = (
384  (* NOTE: maybe we should allow different spec files? *)  (* NOTE: maybe we should allow different spec files? *)
385          (* check that the two databases are compatible *)          (* check that the two databases are compatible *)
386            if (#specfile base <> #specfile ext)            if (#registry base <> #registry ext)
387              then conflict["spec files do not match"]            orelse (#api base <> #api ext)
388              orelse (#profile base <> #profile ext)
389                then conflict["extend: database mismatch"]
390              else ();              else ();
391          (* extend the database tables *)          (* extend the database tables *)
           extendConstants (#constants base, #constants ext);  
392            extendTypes (#types base, #types ext);            extendTypes (#types base, #types ext);
393            extendFuncts (#functions base, #functions ext))            extendEnums (#enums base, #enums ext);
394              extendCommands (#commands base, #commands ext);
395              extendGroups (#groups base, #groups ext);
396              extendFeatures (#features base, #features ext))
397    
398    end    end

Legend:
Removed from v.1376  
changed lines
  Added in v.1377

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