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 1416 - (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 : jhr 1400 fun sortItems keyItemPairList = let
67 : jhr 1365 fun gt ((key1, _), (key2, _)) = atomGT(key1, key2)
68 :     in
69 : jhr 1400 List.map #2 (ListMergeSort.sort gt keyItemPairList)
70 : jhr 1365 end
71 :    
72 : jhr 1400 fun sortTableItems tbl = sortItems (ATbl.listItemsi tbl)
73 :    
74 : jhr 1365 fun toXML (DB content) = X.DB{
75 : jhr 1377 registry = #registry content,
76 :     api = #api content,
77 :     profile = #profile content,
78 :     extensions = #extensions content,
79 :     types = sortTableItems(#types content),
80 :     enums = sortTableItems(#enums content),
81 :     commands = sortTableItems(#commands content),
82 :     groups = sortTableItems(#groups content),
83 :     features = sortTableItems(#features content)
84 : jhr 1365 }
85 :    
86 :     fun fromXML (X.DB content) = let
87 : jhr 1377 val enums = ATbl.mkTable (List.length(#enums content), Fail "enums")
88 :     val insEnum = ATbl.insert enums
89 : jhr 1365 val types = ATbl.mkTable (List.length(#types content), Fail "types")
90 :     val insTy = ATbl.insert types
91 : jhr 1377 val commands = ATbl.mkTable (List.length(#commands content), Fail "functions")
92 :     val insCmd = ATbl.insert commands
93 :     val groups = ATbl.mkTable (List.length(#groups content), Fail "groups")
94 :     val insGrp = ATbl.insert groups
95 :     val features = ATbl.mkTable (List.length(#features content), Fail "features")
96 :     val insFeature = ATbl.insert features
97 : jhr 1365 in
98 :     (* initialize tables *)
99 :     List.app (fn (ty as {name, def}) => insTy(name, ty)) (#types content);
100 : jhr 1377 List.app (fn (enum as {name, ty, value}) => insEnum(name, enum)) (#enums content);
101 :     List.app (fn (cmd as X.Cmd{name, ...}) => insCmd(name, cmd)) (#commands content);
102 :     List.app (fn (grp as X.EnumGrp{name, ...}) => insGrp(name, grp)) (#groups content);
103 :     List.app (fn (f as X.Feature{name, ...}) => insFeature(name, f)) (#features content);
104 : jhr 1365 DB{
105 : jhr 1377 registry = #registry content,
106 :     api = #api content,
107 :     profile = #profile content,
108 :     extensions = #extensions content,
109 :     types = types,
110 :     enums = enums,
111 :     commands = commands,
112 :     groups = groups,
113 :     features = features
114 : jhr 1365 }
115 :     end
116 :    
117 : jhr 1377 (* obsolete
118 : jhr 1365 (* create a new empty database by cloning the meta information from another database *)
119 :     fun clone (DB content) = DB{
120 : jhr 1377 registry = #registry content,
121 :     api = #api content,
122 :     profile = #profile content,
123 :     extensions = #extensions content,
124 : jhr 1365 types = ATbl.mkTable (ATbl.numItems(#types content), Fail "types"),
125 : jhr 1377 enums = ATbl.mkTable (ATbl.numItems(#enums content), Fail "enums"),
126 :     commands = ATbl.mkTable (ATbl.numItems(#commands content), Fail "commands"),
127 :     groups = ATbl.mkTable (ATbl.numItems(#groups content), Fail "groups"),
128 :     features = ATbl.mkTable (ATbl.numItems(#features content), Fail "features")
129 : jhr 1365 }
130 : jhr 1377 *)
131 : jhr 1365
132 : jhr 1377 (* load the specifications for the database into the database. *)
133 :     fun load {regFile, api, profile, extensions} = let
134 :     (* load and check specification *)
135 :     val registry = SpecLoader.load{
136 :     regFile = regFile,
137 :     api = SOME api,
138 :     profile = SOME profile,
139 :     extensions = SOME extensions
140 :     }
141 :     in
142 :     DB{
143 :     registry = regFile,
144 :     api = api,
145 :     profile = profile,
146 :     extensions = extensions,
147 :     types = #types registry,
148 :     enums = #enums registry,
149 :     groups = #groups registry,
150 :     commands = #commands registry,
151 :     features = let
152 :     val tbl = ATbl.mkTable (List.length (#features registry), Fail "features")
153 :     val ins = ATbl.insert tbl
154 :     in
155 :     List.app (fn (f as X.Feature{name, ...}) => ins(name, f)) (#features registry);
156 :     tbl
157 :     end
158 :     }
159 :     end
160 : jhr 1365
161 :     fun conflict msg = raise Fail(concat msg)
162 :    
163 : jhr 1377 (* extend the type table by the constants in ext *)
164 :     fun extendTypes (base, ext) = let
165 : jhr 1365 val findInBase = ATbl.find base
166 :     val insertInBase = ATbl.insert base
167 : jhr 1377 fun extend (ty as {name, def}) = (case findInBase name
168 : jhr 1399 of SOME ty' => if not (CType.same(def, #def ty'))
169 : jhr 1377 then conflict[
170 :     "type ", Atom.toString name, " definition conflict"
171 :     ]
172 :     else ()
173 :     | NONE => insertInBase (name, ty)
174 :     (* end case *))
175 :     in
176 :     ATbl.app extend ext
177 :     end
178 :    
179 :     (* extend the enum table base by the enums in ext *)
180 :     fun extendEnums (base : X.enum AtomTable.hash_table, ext) = let
181 :     val findInBase = ATbl.find base
182 :     val insertInBase = ATbl.insert base
183 :     fun extend (enum as {name, ty, value}) = (case findInBase name
184 :     of NONE => insertInBase(name, enum)
185 :     | SOME{ty=ty', value=value', ...} => let
186 :     val tyConflict = (case (ty, ty')
187 :     of (SOME ty, SOME ty') => not(CType.same(ty, ty'))
188 : jhr 1413 | (SOME ty, NONE) => ((* update type info *)
189 :     insertInBase(name, {name=name, ty=SOME ty, value=value});
190 :     false)
191 : jhr 1416 | _ => false
192 : jhr 1377 (* end case *))
193 :     in
194 : jhr 1416 if tyConflict
195 : jhr 1377 then conflict[
196 : jhr 1416 "enum ", Atom.toString name, " type conflict"
197 :     ]
198 :     else if (value <> value')
199 :     then conflict[
200 : jhr 1377 "enum ", Atom.toString name, " value conflict"
201 :     ]
202 :     else ()
203 :     end
204 :     (* end case *))
205 :     in
206 :     (* do we want to check for enums that have been removed? *)
207 :     ATbl.app extend ext
208 :     end
209 :    
210 :     (* extend the command table by the definitions in ext *)
211 :     fun extendCommands (base, ext) = let
212 :     val findInBase = ATbl.find base
213 :     val insertInBase = ATbl.insert base
214 : jhr 1400 fun mkProtoMap protos = let
215 :     fun ins (proto as X.Proto{name, ...}, m) = AtomMap.insert(m, name, proto)
216 :     in
217 :     List.foldl ins AtomMap.empty protos
218 :     end
219 : jhr 1382 fun extend (cmd as X.Cmd{name, remove, protos}) = (
220 : jhr 1377 case findInBase name
221 :     of SOME(X.Cmd{protos=protos', ...}) => let
222 : jhr 1382 (* FIXME: extend remove *)
223 : jhr 1400 (* we need to add any new prototypes into the existing list. We also
224 :     * need to add mltype attributes, when they are provided by the extension,
225 :     * but not the base.
226 : jhr 1377 *)
227 : jhr 1400 val baseProtos = mkProtoMap protos'
228 :     val extProtos = mkProtoMap protos
229 :     fun merge (X.Proto baseProto, X.Proto extProto) = let
230 :     fun mergeOpts (NONE, SOME x) = SOME x
231 :     | mergeOpts (opt, _) = opt
232 :     (* extend the base return type with any new ML type info *)
233 :     val retTy = {
234 :     cty = #cty(#retTy baseProto),
235 :     mlty = mergeOpts (#mlty(#retTy baseProto), #mlty(#retTy extProto))
236 :     }
237 :     (* extend parameter types with any new ML type info *)
238 :     fun extParam (X.Param baseParam, X.Param extParam) = X.Param{
239 :     name = #name baseParam,
240 :     cty = #cty baseParam,
241 :     group = mergeOpts(#group baseParam, #group extParam),
242 :     mlty = mergeOpts(#mlty baseParam, #mlty extParam)
243 :     }
244 : jhr 1377 in
245 : jhr 1400 X.Proto{
246 :     name = #name baseProto,
247 :     retTy = retTy,
248 :     params = ListPair.mapEq extParam (#params baseProto, #params extProto)
249 :     }
250 : jhr 1377 end
251 :     (* NOTE: we may want to add a consistency check for the overlapping definitions! *)
252 : jhr 1400 (* merge and sort the prototypes *)
253 :     val protos = sortItems (
254 :     AtomMap.listItemsi (
255 :     AtomMap.unionWith merge (baseProtos, extProtos)))
256 : jhr 1377 in
257 : jhr 1400 insertInBase(name, X.Cmd{name=name, remove=remove, protos=protos})
258 : jhr 1377 end
259 :     | NONE => insertInBase(name, cmd)
260 :     (* end case *))
261 :     in
262 :     ATbl.app extend ext
263 :     end
264 :    
265 :     (* extend the enum-group table base by the constants in ext *)
266 :     fun extendGroups (base, ext) = let
267 :     val findInBase = ATbl.find base
268 :     val insertInBase = ATbl.insert base
269 :     fun extend (grp as X.EnumGrp{name=grpName, bitmask, consts}) = (
270 : jhr 1365 case findInBase grpName
271 : jhr 1377 of SOME(X.EnumGrp{bitmask=b, consts=baseConsts, ...}) =>
272 :     if (bitmask <> b)
273 : jhr 1365 then conflict[
274 : jhr 1377 "enum group ", Atom.toString grpName, " bitmask conflict"
275 : jhr 1365 ]
276 :     else let
277 : jhr 1377 (* construct a set of the constants in base *)
278 :     val cSet = ASet.fromList baseConsts
279 :     fun match name = not(ASet.member(cSet, name))
280 : jhr 1365 in
281 :     case List.filter match consts
282 :     of [] => ()
283 : jhr 1377 | cs => insertInBase (grpName, X.EnumGrp{
284 : jhr 1365 name = grpName,
285 : jhr 1377 bitmask = bitmask,
286 : jhr 1365 consts = baseConsts @ cs
287 :     })
288 :     (* end case *)
289 :     end
290 :     | NONE => (* add the group to the base *)
291 :     insertInBase (grpName, grp)
292 :     (* end case *))
293 :     in
294 :     ATbl.app extend ext
295 :     end
296 :    
297 : jhr 1377 (* extend the list of features base by the list ext *)
298 :     fun extendFeatures (base, ext) = let
299 : jhr 1365 val findInBase = ATbl.find base
300 :     val insertInBase = ATbl.insert base
301 : jhr 1377 (* we extend the feature list by either extending a feature or by adding a new
302 :     * feature to the list.
303 :     *)
304 :     fun extend (f as X.Feature{name, version, types, enums, commands}) = (
305 :     case findInBase name
306 :     of SOME(X.Feature{version=v', types=tys', enums=enums', commands=cmds', ...}) => let
307 :     fun extend' (base, ext) = let
308 :     val set = AtomSet.fromList base
309 :     in
310 :     List.filter (fn x => not(AtomSet.member(set, x))) ext
311 :     end
312 :     in
313 :     if (version <> v')
314 :     then conflict["feature ", Atom.toString name, " has conflicting versions"]
315 :     else ();
316 :     case (extend'(types, tys'), extend'(enums, enums'), extend'(commands, cmds'))
317 :     of ([], [], []) => () (* no change *)
318 :     | (newTys, newEnums, newCmds) => insertInBase (name, X.Feature{
319 :     name = name, version = version,
320 :     types = types @ newTys,
321 :     enums = enums @ newEnums,
322 :     commands = commands @ newCmds
323 :     })
324 :     (* end case *)
325 :     end
326 :     | NONE => insertInBase (name, f)
327 :     (* end case *))
328 :     in
329 :     ATbl.app extend ext
330 :     end
331 : jhr 1365
332 : jhr 1377 (*
333 : jhr 1365 fun extend (cat as X.Category{name=catName, functs}) = (
334 :     case findInBase catName
335 :     of SOME(X.Category{functs=baseFuns, ...}) => let
336 :     (* construct a map of the base functions *)
337 :     val baseMap = mkFunMap baseFuns
338 :     fun inBase (X.Fun{name, ...}) = AMap.inDomain(baseMap, name)
339 :     (* partition the extension functions into those that are possible updates
340 :     * of the functions in the base and those that are new.
341 :     *)
342 :     val (updateFns, newFns) = let
343 :     val (ufs, nfs) = List.partition inBase functs
344 :     val uMap = mkFunMap ufs
345 :     in
346 :     (uMap, nfs)
347 :     end
348 :     (* merge a base and extension version of an optional field *)
349 :     fun merge (name, fld, base, ext) = (case (base, ext)
350 :     of (NONE, _) => ext
351 :     | (SOME _, NONE) => base
352 :     | (SOME v1, SOME v2) =>
353 :     if (v1 <> v2)
354 :     then conflict[
355 :     "function ", Atom.toString name, ": ",
356 :     fld, " field has conflicting values"
357 :     ]
358 :     else ext
359 :     (* end case *))
360 :     (* check to see if a base function's definition is modified
361 :     * by the version in the extension. We also make sure that alias
362 :     * functions are consistent with the canonical definition.
363 :     *)
364 :     fun update (baseFn as X.Fun{
365 :     name, alias=NONE, version, deprecated, retTy, params
366 :     }) = (case AMap.find (updateFns, name)
367 :     of NONE => baseFn
368 :     | SOME(X.Fun info) => let
369 :     val version = merge (name, "version", version, #version info)
370 :     val deprecated = merge (name, "deprecated", deprecated, #deprecated info)
371 :     in
372 :     X.Fun{
373 :     name = name, version = version,
374 :     alias = NONE,
375 :     deprecated = deprecated,
376 :     retTy = retTy,
377 :     params = params
378 :     }
379 :     end
380 :     (* end case *))
381 :     | update (baseFn as X.Fun{
382 :     name, alias=SOME name', version, deprecated, retTy, params
383 :     }) = (case AMap.find (updateFns, name')
384 :     of NONE => baseFn
385 :     | SOME(X.Fun info) => let
386 :     (* want the alias to be consistent with the canonical version *)
387 :     val version = merge (name, "version", version, #version info)
388 :     val deprecated = merge (name, "deprecated", deprecated, #deprecated info)
389 :     in
390 :     X.Fun{
391 :     name = name, version = version,
392 :     alias = SOME name',
393 :     deprecated = deprecated,
394 :     retTy = retTy,
395 :     params = params
396 :     }
397 :     end
398 :     (* end case *))
399 :     in
400 :     insertInBase (catName, X.Category{
401 :     name = catName,
402 :     functs = (List.map update baseFuns) @ newFns
403 :     })
404 :     end
405 :     | NONE => insertInBase (catName, cat)
406 :     (* end case *))
407 :     in
408 :     ATbl.app extend ext
409 :     end
410 : jhr 1377 *)
411 : jhr 1365
412 :     (* extend the first database with any additional definitions, etc. that
413 :     * are provided by the second database.
414 :     *)
415 :     fun extend (DB base, DB ext) = (
416 :     (* NOTE: maybe we should allow different spec files? *)
417 :     (* check that the two databases are compatible *)
418 : jhr 1377 if (#registry base <> #registry ext)
419 :     orelse (#api base <> #api ext)
420 :     orelse (#profile base <> #profile ext)
421 :     then conflict["extend: database mismatch"]
422 : jhr 1365 else ();
423 :     (* extend the database tables *)
424 :     extendTypes (#types base, #types ext);
425 : jhr 1377 extendEnums (#enums base, #enums ext);
426 :     extendCommands (#commands base, #commands ext);
427 :     extendGroups (#groups base, #groups ext);
428 :     extendFeatures (#features base, #features ext))
429 : jhr 1365
430 :     end

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