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 1413 - (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 1377 | (NONE, NONE) => false
192 :     | _ => true
193 :     (* end case *))
194 :     in
195 :     if tyConflict orelse (value <> value')
196 :     then conflict[
197 :     "enum ", Atom.toString name, " value conflict"
198 :     ]
199 :     else ()
200 :     end
201 :     (* end case *))
202 :     in
203 :     (* do we want to check for enums that have been removed? *)
204 :     ATbl.app extend ext
205 :     end
206 :    
207 :     (* extend the command table by the definitions in ext *)
208 :     fun extendCommands (base, ext) = let
209 :     val findInBase = ATbl.find base
210 :     val insertInBase = ATbl.insert base
211 : jhr 1400 fun mkProtoMap protos = let
212 :     fun ins (proto as X.Proto{name, ...}, m) = AtomMap.insert(m, name, proto)
213 :     in
214 :     List.foldl ins AtomMap.empty protos
215 :     end
216 : jhr 1382 fun extend (cmd as X.Cmd{name, remove, protos}) = (
217 : jhr 1377 case findInBase name
218 :     of SOME(X.Cmd{protos=protos', ...}) => let
219 : jhr 1382 (* FIXME: extend remove *)
220 : jhr 1400 (* we need to add any new prototypes into the existing list. We also
221 :     * need to add mltype attributes, when they are provided by the extension,
222 :     * but not the base.
223 : jhr 1377 *)
224 : jhr 1400 val baseProtos = mkProtoMap protos'
225 :     val extProtos = mkProtoMap protos
226 :     fun merge (X.Proto baseProto, X.Proto extProto) = let
227 :     fun mergeOpts (NONE, SOME x) = SOME x
228 :     | mergeOpts (opt, _) = opt
229 :     (* extend the base return type with any new ML type info *)
230 :     val retTy = {
231 :     cty = #cty(#retTy baseProto),
232 :     mlty = mergeOpts (#mlty(#retTy baseProto), #mlty(#retTy extProto))
233 :     }
234 :     (* extend parameter types with any new ML type info *)
235 :     fun extParam (X.Param baseParam, X.Param extParam) = X.Param{
236 :     name = #name baseParam,
237 :     cty = #cty baseParam,
238 :     group = mergeOpts(#group baseParam, #group extParam),
239 :     mlty = mergeOpts(#mlty baseParam, #mlty extParam)
240 :     }
241 : jhr 1377 in
242 : jhr 1400 X.Proto{
243 :     name = #name baseProto,
244 :     retTy = retTy,
245 :     params = ListPair.mapEq extParam (#params baseProto, #params extProto)
246 :     }
247 : jhr 1377 end
248 :     (* NOTE: we may want to add a consistency check for the overlapping definitions! *)
249 : jhr 1400 (* merge and sort the prototypes *)
250 :     val protos = sortItems (
251 :     AtomMap.listItemsi (
252 :     AtomMap.unionWith merge (baseProtos, extProtos)))
253 : jhr 1377 in
254 : jhr 1400 insertInBase(name, X.Cmd{name=name, remove=remove, protos=protos})
255 : jhr 1377 end
256 :     | NONE => insertInBase(name, cmd)
257 :     (* end case *))
258 :     in
259 :     ATbl.app extend ext
260 :     end
261 :    
262 :     (* extend the enum-group table base by the constants in ext *)
263 :     fun extendGroups (base, ext) = let
264 :     val findInBase = ATbl.find base
265 :     val insertInBase = ATbl.insert base
266 :     fun extend (grp as X.EnumGrp{name=grpName, bitmask, consts}) = (
267 : jhr 1365 case findInBase grpName
268 : jhr 1377 of SOME(X.EnumGrp{bitmask=b, consts=baseConsts, ...}) =>
269 :     if (bitmask <> b)
270 : jhr 1365 then conflict[
271 : jhr 1377 "enum group ", Atom.toString grpName, " bitmask conflict"
272 : jhr 1365 ]
273 :     else let
274 : jhr 1377 (* construct a set of the constants in base *)
275 :     val cSet = ASet.fromList baseConsts
276 :     fun match name = not(ASet.member(cSet, name))
277 : jhr 1365 in
278 :     case List.filter match consts
279 :     of [] => ()
280 : jhr 1377 | cs => insertInBase (grpName, X.EnumGrp{
281 : jhr 1365 name = grpName,
282 : jhr 1377 bitmask = bitmask,
283 : jhr 1365 consts = baseConsts @ cs
284 :     })
285 :     (* end case *)
286 :     end
287 :     | NONE => (* add the group to the base *)
288 :     insertInBase (grpName, grp)
289 :     (* end case *))
290 :     in
291 :     ATbl.app extend ext
292 :     end
293 :    
294 : jhr 1377 (* extend the list of features base by the list ext *)
295 :     fun extendFeatures (base, ext) = let
296 : jhr 1365 val findInBase = ATbl.find base
297 :     val insertInBase = ATbl.insert base
298 : jhr 1377 (* we extend the feature list by either extending a feature or by adding a new
299 :     * feature to the list.
300 :     *)
301 :     fun extend (f as X.Feature{name, version, types, enums, commands}) = (
302 :     case findInBase name
303 :     of SOME(X.Feature{version=v', types=tys', enums=enums', commands=cmds', ...}) => let
304 :     fun extend' (base, ext) = let
305 :     val set = AtomSet.fromList base
306 :     in
307 :     List.filter (fn x => not(AtomSet.member(set, x))) ext
308 :     end
309 :     in
310 :     if (version <> v')
311 :     then conflict["feature ", Atom.toString name, " has conflicting versions"]
312 :     else ();
313 :     case (extend'(types, tys'), extend'(enums, enums'), extend'(commands, cmds'))
314 :     of ([], [], []) => () (* no change *)
315 :     | (newTys, newEnums, newCmds) => insertInBase (name, X.Feature{
316 :     name = name, version = version,
317 :     types = types @ newTys,
318 :     enums = enums @ newEnums,
319 :     commands = commands @ newCmds
320 :     })
321 :     (* end case *)
322 :     end
323 :     | NONE => insertInBase (name, f)
324 :     (* end case *))
325 :     in
326 :     ATbl.app extend ext
327 :     end
328 : jhr 1365
329 : jhr 1377 (*
330 : jhr 1365 fun extend (cat as X.Category{name=catName, functs}) = (
331 :     case findInBase catName
332 :     of SOME(X.Category{functs=baseFuns, ...}) => let
333 :     (* construct a map of the base functions *)
334 :     val baseMap = mkFunMap baseFuns
335 :     fun inBase (X.Fun{name, ...}) = AMap.inDomain(baseMap, name)
336 :     (* partition the extension functions into those that are possible updates
337 :     * of the functions in the base and those that are new.
338 :     *)
339 :     val (updateFns, newFns) = let
340 :     val (ufs, nfs) = List.partition inBase functs
341 :     val uMap = mkFunMap ufs
342 :     in
343 :     (uMap, nfs)
344 :     end
345 :     (* merge a base and extension version of an optional field *)
346 :     fun merge (name, fld, base, ext) = (case (base, ext)
347 :     of (NONE, _) => ext
348 :     | (SOME _, NONE) => base
349 :     | (SOME v1, SOME v2) =>
350 :     if (v1 <> v2)
351 :     then conflict[
352 :     "function ", Atom.toString name, ": ",
353 :     fld, " field has conflicting values"
354 :     ]
355 :     else ext
356 :     (* end case *))
357 :     (* check to see if a base function's definition is modified
358 :     * by the version in the extension. We also make sure that alias
359 :     * functions are consistent with the canonical definition.
360 :     *)
361 :     fun update (baseFn as X.Fun{
362 :     name, alias=NONE, version, deprecated, retTy, params
363 :     }) = (case AMap.find (updateFns, name)
364 :     of NONE => baseFn
365 :     | SOME(X.Fun info) => let
366 :     val version = merge (name, "version", version, #version info)
367 :     val deprecated = merge (name, "deprecated", deprecated, #deprecated info)
368 :     in
369 :     X.Fun{
370 :     name = name, version = version,
371 :     alias = NONE,
372 :     deprecated = deprecated,
373 :     retTy = retTy,
374 :     params = params
375 :     }
376 :     end
377 :     (* end case *))
378 :     | update (baseFn as X.Fun{
379 :     name, alias=SOME name', version, deprecated, retTy, params
380 :     }) = (case AMap.find (updateFns, name')
381 :     of NONE => baseFn
382 :     | SOME(X.Fun info) => let
383 :     (* want the alias to be consistent with the canonical version *)
384 :     val version = merge (name, "version", version, #version info)
385 :     val deprecated = merge (name, "deprecated", deprecated, #deprecated info)
386 :     in
387 :     X.Fun{
388 :     name = name, version = version,
389 :     alias = SOME name',
390 :     deprecated = deprecated,
391 :     retTy = retTy,
392 :     params = params
393 :     }
394 :     end
395 :     (* end case *))
396 :     in
397 :     insertInBase (catName, X.Category{
398 :     name = catName,
399 :     functs = (List.map update baseFuns) @ newFns
400 :     })
401 :     end
402 :     | NONE => insertInBase (catName, cat)
403 :     (* end case *))
404 :     in
405 :     ATbl.app extend ext
406 :     end
407 : jhr 1377 *)
408 : jhr 1365
409 :     (* extend the first database with any additional definitions, etc. that
410 :     * are provided by the second database.
411 :     *)
412 :     fun extend (DB base, DB ext) = (
413 :     (* NOTE: maybe we should allow different spec files? *)
414 :     (* check that the two databases are compatible *)
415 : jhr 1377 if (#registry base <> #registry ext)
416 :     orelse (#api base <> #api ext)
417 :     orelse (#profile base <> #profile ext)
418 :     then conflict["extend: database mismatch"]
419 : jhr 1365 else ();
420 :     (* extend the database tables *)
421 :     extendTypes (#types base, #types ext);
422 : jhr 1377 extendEnums (#enums base, #enums ext);
423 :     extendCommands (#commands base, #commands ext);
424 :     extendGroups (#groups base, #groups ext);
425 :     extendFeatures (#features base, #features ext))
426 : jhr 1365
427 :     end

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