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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1377 - (view) (download)

1 : jhr 1365 (* db.sml
2 :     *
3 :     * COPYRIGHT (c) 2014 The SML3d Project (http://sml3d.cs.uchicago.edu)
4 :     * All rights reserved.
5 : jhr 1373 *
6 :     * We should use the SpecLoader.registry representation for the database. Perhaps it will
7 :     * need to be made closer to the DBXML representation, but there is no reason for yet another
8 :     * representation of basically the same information!
9 : jhr 1365 *)
10 :    
11 :     structure DB : sig
12 :    
13 :     type db
14 :    
15 : jhr 1377 val toXML : db -> DBXMLRep.db
16 :     val fromXML : DBXMLRep.db -> db
17 : jhr 1365
18 : jhr 1373 (* NOTE: probably don't need this function *)
19 : jhr 1365 (* load the specifications for the database into the database. If the database is not
20 :     * empty, then the Fail exception is raised.
21 :     *)
22 : jhr 1377 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 : jhr 1365
29 :     (* extend the first database with any additional definitions, etc. that are provided by
30 :     * the second database.
31 :     *)
32 :     val extend : db * db -> unit
33 :    
34 :     end = struct
35 :    
36 :     structure X = DBXMLRep
37 :     structure ATbl = AtomTable
38 :     structure AMap = AtomMap
39 :     structure ASet = AtomSet
40 :    
41 :     datatype db = DB of {
42 : jhr 1373 registry : string, (* specification file pathname *)
43 :     api : string,
44 :     profile : string,
45 :     extensions : string,
46 : jhr 1377 types : X.ty AtomTable.hash_table,
47 :     enums : X.enum AtomTable.hash_table,
48 :     groups : X.enum_grp AtomTable.hash_table,
49 :     commands : X.cmd AtomTable.hash_table,
50 :     features : X.feature AtomTable.hash_table
51 : jhr 1365 }
52 :    
53 :     (* check to see if a database is empty *)
54 : jhr 1377 fun isEmpty (DB{types, enums, commands, ...}) =
55 :     (ATbl.numItems types = 0) andalso (ATbl.numItems enums = 0)
56 :     andalso (ATbl.numItems commands = 0)
57 : jhr 1365
58 :     (* comparison function on atoms that we can use with ListMergeSort.sort to sort in ascending
59 :     * lexical order.
60 :     *)
61 :     fun atomGT (a, b) = (case Atom.lexCompare(a, b)
62 :     of GREATER => true
63 :     | _ => false
64 :     (* end case *))
65 :    
66 :     fun sortTableItems tbl = let
67 :     fun gt ((key1, _), (key2, _)) = atomGT(key1, key2)
68 :     in
69 :     List.map #2 (ListMergeSort.sort gt (ATbl.listItemsi tbl))
70 :     end
71 :    
72 :     fun toXML (DB content) = X.DB{
73 : jhr 1377 registry = #registry content,
74 :     api = #api content,
75 :     profile = #profile content,
76 :     extensions = #extensions content,
77 :     types = sortTableItems(#types content),
78 :     enums = sortTableItems(#enums content),
79 :     commands = sortTableItems(#commands content),
80 :     groups = sortTableItems(#groups content),
81 :     features = sortTableItems(#features content)
82 : jhr 1365 }
83 :    
84 :     fun fromXML (X.DB content) = let
85 : jhr 1377 val enums = ATbl.mkTable (List.length(#enums content), Fail "enums")
86 :     val insEnum = ATbl.insert enums
87 : jhr 1365 val types = ATbl.mkTable (List.length(#types content), Fail "types")
88 :     val insTy = ATbl.insert types
89 : jhr 1377 val commands = ATbl.mkTable (List.length(#commands content), Fail "functions")
90 :     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 : jhr 1365 in
96 :     (* initialize tables *)
97 :     List.app (fn (ty as {name, def}) => insTy(name, ty)) (#types content);
98 : jhr 1377 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 : jhr 1365 DB{
103 : jhr 1377 registry = #registry content,
104 :     api = #api content,
105 :     profile = #profile content,
106 :     extensions = #extensions content,
107 :     types = types,
108 :     enums = enums,
109 :     commands = commands,
110 :     groups = groups,
111 :     features = features
112 : jhr 1365 }
113 :     end
114 :    
115 : jhr 1377 (* obsolete
116 : jhr 1365 (* create a new empty database by cloning the meta information from another database *)
117 :     fun clone (DB content) = DB{
118 : jhr 1377 registry = #registry content,
119 :     api = #api content,
120 :     profile = #profile content,
121 :     extensions = #extensions content,
122 : jhr 1365 types = ATbl.mkTable (ATbl.numItems(#types content), Fail "types"),
123 : jhr 1377 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 : jhr 1365 }
128 : jhr 1377 *)
129 : jhr 1365
130 : jhr 1377 (* load the specifications for the database into the database. *)
131 :     fun load {regFile, api, profile, extensions} = let
132 :     (* load and check specification *)
133 :     val registry = SpecLoader.load{
134 :     regFile = regFile,
135 :     api = SOME api,
136 :     profile = SOME profile,
137 :     extensions = SOME extensions
138 :     }
139 :     in
140 :     DB{
141 :     registry = regFile,
142 :     api = api,
143 :     profile = profile,
144 :     extensions = extensions,
145 :     types = #types registry,
146 :     enums = #enums registry,
147 :     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
156 :     }
157 :     end
158 : jhr 1365
159 :     fun conflict msg = raise Fail(concat msg)
160 :    
161 : jhr 1377 (* extend the type table by the constants in ext *)
162 :     fun extendTypes (base, ext) = let
163 : jhr 1365 val findInBase = ATbl.find base
164 :     val insertInBase = ATbl.insert base
165 : jhr 1377 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
174 :     ATbl.app extend ext
175 :     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
190 :     if tyConflict orelse (value <> value')
191 :     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
201 :    
202 :     (* 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 enum-group table base by the constants in ext *)
234 :     fun extendGroups (base, ext) = let
235 :     val findInBase = ATbl.find base
236 :     val insertInBase = ATbl.insert base
237 :     fun extend (grp as X.EnumGrp{name=grpName, bitmask, consts}) = (
238 : jhr 1365 case findInBase grpName
239 : jhr 1377 of SOME(X.EnumGrp{bitmask=b, consts=baseConsts, ...}) =>
240 :     if (bitmask <> b)
241 : jhr 1365 then conflict[
242 : jhr 1377 "enum group ", Atom.toString grpName, " bitmask conflict"
243 : jhr 1365 ]
244 :     else let
245 : jhr 1377 (* construct a set of the constants in base *)
246 :     val cSet = ASet.fromList baseConsts
247 :     fun match name = not(ASet.member(cSet, name))
248 : jhr 1365 in
249 :     case List.filter match consts
250 :     of [] => ()
251 : jhr 1377 | cs => insertInBase (grpName, X.EnumGrp{
252 : jhr 1365 name = grpName,
253 : jhr 1377 bitmask = bitmask,
254 : jhr 1365 consts = baseConsts @ cs
255 :     })
256 :     (* end case *)
257 :     end
258 :     | NONE => (* add the group to the base *)
259 :     insertInBase (grpName, grp)
260 :     (* end case *))
261 :     in
262 :     ATbl.app extend ext
263 :     end
264 :    
265 : jhr 1377 (* extend the list of features base by the list ext *)
266 :     fun extendFeatures (base, ext) = let
267 : jhr 1365 val findInBase = ATbl.find base
268 :     val insertInBase = ATbl.insert base
269 : jhr 1377 (* we extend the feature list by either extending a feature or by adding a new
270 :     * feature to the list.
271 :     *)
272 :     fun extend (f as X.Feature{name, version, types, enums, commands}) = (
273 :     case findInBase name
274 :     of SOME(X.Feature{version=v', types=tys', enums=enums', commands=cmds', ...}) => let
275 :     fun extend' (base, ext) = let
276 :     val set = AtomSet.fromList base
277 :     in
278 :     List.filter (fn x => not(AtomSet.member(set, x))) ext
279 :     end
280 :     in
281 :     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
299 : jhr 1365
300 : jhr 1377 (*
301 : jhr 1365 fun extend (cat as X.Category{name=catName, functs}) = (
302 :     case findInBase catName
303 :     of SOME(X.Category{functs=baseFuns, ...}) => let
304 :     (* construct a map of the base functions *)
305 :     val baseMap = mkFunMap baseFuns
306 :     fun inBase (X.Fun{name, ...}) = AMap.inDomain(baseMap, name)
307 :     (* partition the extension functions into those that are possible updates
308 :     * of the functions in the base and those that are new.
309 :     *)
310 :     val (updateFns, newFns) = let
311 :     val (ufs, nfs) = List.partition inBase functs
312 :     val uMap = mkFunMap ufs
313 :     in
314 :     (uMap, nfs)
315 :     end
316 :     (* merge a base and extension version of an optional field *)
317 :     fun merge (name, fld, base, ext) = (case (base, ext)
318 :     of (NONE, _) => ext
319 :     | (SOME _, NONE) => base
320 :     | (SOME v1, SOME v2) =>
321 :     if (v1 <> v2)
322 :     then conflict[
323 :     "function ", Atom.toString name, ": ",
324 :     fld, " field has conflicting values"
325 :     ]
326 :     else ext
327 :     (* end case *))
328 :     (* check to see if a base function's definition is modified
329 :     * by the version in the extension. We also make sure that alias
330 :     * functions are consistent with the canonical definition.
331 :     *)
332 :     fun update (baseFn as X.Fun{
333 :     name, alias=NONE, version, deprecated, retTy, params
334 :     }) = (case AMap.find (updateFns, name)
335 :     of NONE => baseFn
336 :     | SOME(X.Fun info) => let
337 :     val version = merge (name, "version", version, #version info)
338 :     val deprecated = merge (name, "deprecated", deprecated, #deprecated info)
339 :     in
340 :     X.Fun{
341 :     name = name, version = version,
342 :     alias = NONE,
343 :     deprecated = deprecated,
344 :     retTy = retTy,
345 :     params = params
346 :     }
347 :     end
348 :     (* end case *))
349 :     | update (baseFn as X.Fun{
350 :     name, alias=SOME name', version, deprecated, retTy, params
351 :     }) = (case AMap.find (updateFns, name')
352 :     of NONE => baseFn
353 :     | SOME(X.Fun info) => let
354 :     (* want the alias to be consistent with the canonical version *)
355 :     val version = merge (name, "version", version, #version info)
356 :     val deprecated = merge (name, "deprecated", deprecated, #deprecated info)
357 :     in
358 :     X.Fun{
359 :     name = name, version = version,
360 :     alias = SOME name',
361 :     deprecated = deprecated,
362 :     retTy = retTy,
363 :     params = params
364 :     }
365 :     end
366 :     (* end case *))
367 :     in
368 :     insertInBase (catName, X.Category{
369 :     name = catName,
370 :     functs = (List.map update baseFuns) @ newFns
371 :     })
372 :     end
373 :     | NONE => insertInBase (catName, cat)
374 :     (* end case *))
375 :     in
376 :     ATbl.app extend ext
377 :     end
378 : jhr 1377 *)
379 : jhr 1365
380 :     (* extend the first database with any additional definitions, etc. that
381 :     * are provided by the second database.
382 :     *)
383 :     fun extend (DB base, DB ext) = (
384 :     (* NOTE: maybe we should allow different spec files? *)
385 :     (* check that the two databases are compatible *)
386 : jhr 1377 if (#registry base <> #registry ext)
387 :     orelse (#api base <> #api ext)
388 :     orelse (#profile base <> #profile ext)
389 :     then conflict["extend: database mismatch"]
390 : jhr 1365 else ();
391 :     (* extend the database tables *)
392 :     extendTypes (#types base, #types ext);
393 : jhr 1377 extendEnums (#enums base, #enums ext);
394 :     extendCommands (#commands base, #commands ext);
395 :     extendGroups (#groups base, #groups ext);
396 :     extendFeatures (#features base, #features ext))
397 : jhr 1365
398 :     end

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