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

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