SCM Repository
Annotation of /trunk/sml3d/gen/gen-from-xml/gldb/db.sml
Parent Directory
|
Revision Log
Revision 1373 - (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 : | val toXML : db -> XMLRep.db | ||
16 : | val fromXML : XMLRep.db -> db | ||
17 : | |||
18 : | jhr | 1373 | (* create a database from a Khronos XML specification file *) |
19 : | val fromGLSpec : SpecLoader.registry -> db | ||
20 : | |||
21 : | (* NOTE: probably don't need this function *) | ||
22 : | jhr | 1365 | (* create a new empty database by cloning the meta information from another database *) |
23 : | val clone : db -> db | ||
24 : | |||
25 : | jhr | 1373 | (* NOTE: probably don't need this function *) |
26 : | jhr | 1365 | (* load the specifications for the database into the database. If the database is not |
27 : | * empty, then the Fail exception is raised. | ||
28 : | *) | ||
29 : | val load : db -> unit | ||
30 : | |||
31 : | (* extend the first database with any additional definitions, etc. that are provided by | ||
32 : | * the second database. | ||
33 : | *) | ||
34 : | val extend : db * db -> unit | ||
35 : | |||
36 : | end = struct | ||
37 : | |||
38 : | structure X = DBXMLRep | ||
39 : | structure Rep = SpecRep (* Khronos specification file representation *) | ||
40 : | structure ATbl = AtomTable | ||
41 : | structure AMap = AtomMap | ||
42 : | structure ASet = AtomSet | ||
43 : | |||
44 : | datatype db = DB of { | ||
45 : | jhr | 1373 | registry : string, (* specification file pathname *) |
46 : | api : string, | ||
47 : | profile : string, | ||
48 : | extensions : string, | ||
49 : | jhr | 1365 | constants : X.const_grp ATbl.hash_table, |
50 : | types : X.ty ATbl.hash_table, | ||
51 : | functions : X.category ATbl.hash_table | ||
52 : | } | ||
53 : | |||
54 : | (* check to see if a database is empty *) | ||
55 : | fun isEmpty (DB{constants, types, functions, ...}) = | ||
56 : | (ATbl.numItems constants = 0) andalso (ATbl.numItems types = 0) | ||
57 : | andalso (ATbl.numItems functions = 0) | ||
58 : | |||
59 : | (* comparison function on atoms that we can use with ListMergeSort.sort to sort in ascending | ||
60 : | * lexical order. | ||
61 : | *) | ||
62 : | fun atomGT (a, b) = (case Atom.lexCompare(a, b) | ||
63 : | of GREATER => true | ||
64 : | | _ => false | ||
65 : | (* end case *)) | ||
66 : | |||
67 : | fun sortTableItems tbl = let | ||
68 : | fun gt ((key1, _), (key2, _)) = atomGT(key1, key2) | ||
69 : | in | ||
70 : | List.map #2 (ListMergeSort.sort gt (ATbl.listItemsi tbl)) | ||
71 : | end | ||
72 : | |||
73 : | (* sort constant groups by name *) | ||
74 : | local | ||
75 : | fun gt (X.ConstGrp{name=a, ...}, X.ConstGrp{name=b, ...}) = atomGT (a, b) | ||
76 : | in | ||
77 : | val sortConstGrps = ListMergeSort.sort gt | ||
78 : | end | ||
79 : | |||
80 : | fun toXML (DB content) = X.DB{ | ||
81 : | specfile = #specfile content, | ||
82 : | constants = sortTableItems(#constants content), | ||
83 : | types = sortTableItems(#types content), | ||
84 : | functions = sortTableItems(#functions content) | ||
85 : | } | ||
86 : | |||
87 : | fun fromXML (X.DB content) = let | ||
88 : | val constants = ATbl.mkTable (List.length(#constants content), Fail "constants") | ||
89 : | val insConst = ATbl.insert constants | ||
90 : | val types = ATbl.mkTable (List.length(#types content), Fail "types") | ||
91 : | val insTy = ATbl.insert types | ||
92 : | val functions = ATbl.mkTable (List.length(#functions content), Fail "functions") | ||
93 : | val insFn = ATbl.insert functions | ||
94 : | in | ||
95 : | (* initialize tables *) | ||
96 : | 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); | ||
98 : | DB{ | ||
99 : | specfile = #specfile content, | ||
100 : | constants = constants, | ||
101 : | types = types, | ||
102 : | functions = functions | ||
103 : | } | ||
104 : | end | ||
105 : | |||
106 : | (* create a new empty database by cloning the meta information from another database *) | ||
107 : | fun clone (DB content) = DB{ | ||
108 : | specfile = #specfile content, | ||
109 : | constants = ATbl.mkTable (ATbl.numItems(#constants content), Fail "constants"), | ||
110 : | types = ATbl.mkTable (ATbl.numItems(#types content), Fail "types"), | ||
111 : | functions = ATbl.mkTable (ATbl.numItems(#functions content), Fail "functions") | ||
112 : | } | ||
113 : | |||
114 : | (* load the specifications for the database into the database. If the database is not | ||
115 : | * empty, then the Fail exception is raised. | ||
116 : | *) | ||
117 : | fun load (db as DB content) = if (isEmpty db) | ||
118 : | then let | ||
119 : | (* load and check specification *) | ||
120 : | val spec = SpecParser (#specfile db) | ||
121 : | (* insertion functions for database tables *) | ||
122 : | val insConst = ATbl.insert (#constants content) | ||
123 : | val insTy = ATbl.insert (#types content) | ||
124 : | val insCat = ATbl.insert (#functions content) | ||
125 : | val findCat = ATbl.find (#functions content) | ||
126 : | (* insert an enum definition *) | ||
127 : | fun insEnum (Enums.Enum{name, kind, consts}) = let | ||
128 : | fun cvtConst (name, v, from) = { | ||
129 : | name = name, | ||
130 : | value = (case v | ||
131 : | of Enums.HEX s => s | ||
132 : | | Enums.DEC s => s | ||
133 : | | Enums.SYM s => s | ||
134 : | (* end case *)), | ||
135 : | from = from | ||
136 : | } | ||
137 : | in | ||
138 : | insConst (name, X.ConstGrp{ | ||
139 : | name = name, | ||
140 : | kind = (case kind | ||
141 : | of Enums.DEFINE => X.DEFINE | ||
142 : | | Enums.ENUM => X.ENUM | ||
143 : | | Enums.MASK => X.MASK | ||
144 : | (* end case *)), | ||
145 : | consts = List.map cvtConst consts | ||
146 : | }) | ||
147 : | end | ||
148 : | (* insert the functions from a category *) | ||
149 : | fun insCategory (cat, fs) = let | ||
150 : | fun cvtParam (Functs.Param{name, ty, dir, xferTy}) = X.Param{ | ||
151 : | name = name, | ||
152 : | cty = ty, | ||
153 : | mlty = NONE (* FIXME *) | ||
154 : | } | ||
155 : | fun cvtFunct (Functs.Fun content) = X.Fun{ | ||
156 : | name = #name content, | ||
157 : | alias = NONE, (* no aliases in spec files *) | ||
158 : | version = #version content, | ||
159 : | deprecated = #deprecated content, | ||
160 : | retTy = { | ||
161 : | cty = #returnTy content, | ||
162 : | mlty = NONE (* FIXME *) | ||
163 : | }, | ||
164 : | params = List.map cvtParam (#params content) | ||
165 : | } | ||
166 : | in | ||
167 : | case (cat, fs) | ||
168 : | of (NONE, []) => () | ||
169 : | | (NONE, _) => raise Fail "default category" | ||
170 : | | (SOME cat, _) => | ||
171 : | insCat (cat, X.Category{name = cat, functs = List.map cvtFunct fs}) | ||
172 : | (* end case *) | ||
173 : | end | ||
174 : | in | ||
175 : | Enums.app insEnum enums; | ||
176 : | Functs.appByCategory insCategory functs | ||
177 : | end | ||
178 : | else raise Fail "load on non-empty database" | ||
179 : | |||
180 : | fun conflict msg = raise Fail(concat msg) | ||
181 : | |||
182 : | (* extend the constant table base by the constants in ext *) | ||
183 : | fun extendConstants (base, ext) = let | ||
184 : | val findInBase = ATbl.find base | ||
185 : | val insertInBase = ATbl.insert base | ||
186 : | fun extend (grp as X.ConstGrp{name=grpName, kind, consts}) = ( | ||
187 : | case findInBase grpName | ||
188 : | of SOME(X.ConstGrp{kind=k, consts=baseConsts, ...}) => | ||
189 : | if (kind <> k) | ||
190 : | then conflict[ | ||
191 : | "constant group ", Atom.toString grpName, " kind conflict" | ||
192 : | ] | ||
193 : | else let | ||
194 : | (* construct a mapping for the base constants *) | ||
195 : | val cMap = List.foldl | ||
196 : | (fn (c, m) => AMap.insert(m, #name c, c)) | ||
197 : | AMap.empty | ||
198 : | baseConsts | ||
199 : | fun match {name, value, from} = (case AMap.find(cMap, name) | ||
200 : | of NONE => true | ||
201 : | | SOME c => if (value <> #value c) | ||
202 : | andalso (case (from, #from c) | ||
203 : | of (NONE, NONE) => true | ||
204 : | | (SOME a, SOME b) => Atom.same(a, b) | ||
205 : | | _ => false) | ||
206 : | then conflict[ | ||
207 : | "constant ", Atom.toString grpName, | ||
208 : | " ", Atom.toString name, " value conflict" | ||
209 : | ] | ||
210 : | else false | ||
211 : | (* end case *)) | ||
212 : | in | ||
213 : | case List.filter match consts | ||
214 : | of [] => () | ||
215 : | | cs => insertInBase (grpName, X.ConstGrp{ | ||
216 : | name = grpName, | ||
217 : | kind = kind, | ||
218 : | consts = baseConsts @ cs | ||
219 : | }) | ||
220 : | (* end case *) | ||
221 : | end | ||
222 : | | NONE => (* add the group to the base *) | ||
223 : | insertInBase (grpName, grp) | ||
224 : | (* end case *)) | ||
225 : | in | ||
226 : | ATbl.app extend ext | ||
227 : | end | ||
228 : | |||
229 : | (* extend the type table by the constants in ext *) | ||
230 : | fun extendTypes (base, ext) = let | ||
231 : | val findInBase = ATbl.find base | ||
232 : | val insertInBase = ATbl.insert base | ||
233 : | fun extend (ty as {name, def}) = (case findInBase name | ||
234 : | of SOME ty' => if CType.same(def, #def ty') | ||
235 : | then conflict[ | ||
236 : | "type ", Atom.toString name, " definition conflict" | ||
237 : | ] | ||
238 : | else () | ||
239 : | | NONE => insertInBase (name, ty) | ||
240 : | (* end case *)) | ||
241 : | in | ||
242 : | ATbl.app extend ext | ||
243 : | end | ||
244 : | |||
245 : | (* construct a finite map from a list of functions *) | ||
246 : | fun mkFunMap fns = let | ||
247 : | fun ins (f as X.Fun{name, ...}, m) = AMap.insert(m, name, f) | ||
248 : | in | ||
249 : | List.foldl ins AMap.empty fns | ||
250 : | end | ||
251 : | |||
252 : | (* extend the function table by the definitions in ext *) | ||
253 : | fun extendFuncts (base, ext) = let | ||
254 : | val findInBase = ATbl.find base | ||
255 : | val insertInBase = ATbl.insert base | ||
256 : | fun extend (cat as X.Category{name=catName, functs}) = ( | ||
257 : | case findInBase catName | ||
258 : | of SOME(X.Category{functs=baseFuns, ...}) => let | ||
259 : | (* construct a map of the base functions *) | ||
260 : | val baseMap = mkFunMap baseFuns | ||
261 : | fun inBase (X.Fun{name, ...}) = AMap.inDomain(baseMap, name) | ||
262 : | (* partition the extension functions into those that are possible updates | ||
263 : | * of the functions in the base and those that are new. | ||
264 : | *) | ||
265 : | val (updateFns, newFns) = let | ||
266 : | val (ufs, nfs) = List.partition inBase functs | ||
267 : | val uMap = mkFunMap ufs | ||
268 : | in | ||
269 : | (uMap, nfs) | ||
270 : | end | ||
271 : | (* merge a base and extension version of an optional field *) | ||
272 : | fun merge (name, fld, base, ext) = (case (base, ext) | ||
273 : | of (NONE, _) => ext | ||
274 : | | (SOME _, NONE) => base | ||
275 : | | (SOME v1, SOME v2) => | ||
276 : | if (v1 <> v2) | ||
277 : | then conflict[ | ||
278 : | "function ", Atom.toString name, ": ", | ||
279 : | fld, " field has conflicting values" | ||
280 : | ] | ||
281 : | else ext | ||
282 : | (* end case *)) | ||
283 : | (* check to see if a base function's definition is modified | ||
284 : | * by the version in the extension. We also make sure that alias | ||
285 : | * functions are consistent with the canonical definition. | ||
286 : | *) | ||
287 : | fun update (baseFn as X.Fun{ | ||
288 : | name, alias=NONE, version, deprecated, retTy, params | ||
289 : | }) = (case AMap.find (updateFns, name) | ||
290 : | of NONE => baseFn | ||
291 : | | SOME(X.Fun info) => let | ||
292 : | val version = merge (name, "version", version, #version info) | ||
293 : | val deprecated = merge (name, "deprecated", deprecated, #deprecated info) | ||
294 : | in | ||
295 : | X.Fun{ | ||
296 : | name = name, version = version, | ||
297 : | alias = NONE, | ||
298 : | deprecated = deprecated, | ||
299 : | retTy = retTy, | ||
300 : | params = params | ||
301 : | } | ||
302 : | end | ||
303 : | (* end case *)) | ||
304 : | | update (baseFn as X.Fun{ | ||
305 : | name, alias=SOME name', version, deprecated, retTy, params | ||
306 : | }) = (case AMap.find (updateFns, name') | ||
307 : | of NONE => baseFn | ||
308 : | | SOME(X.Fun info) => let | ||
309 : | (* want the alias to be consistent with the canonical version *) | ||
310 : | val version = merge (name, "version", version, #version info) | ||
311 : | val deprecated = merge (name, "deprecated", deprecated, #deprecated info) | ||
312 : | in | ||
313 : | X.Fun{ | ||
314 : | name = name, version = version, | ||
315 : | alias = SOME name', | ||
316 : | deprecated = deprecated, | ||
317 : | retTy = retTy, | ||
318 : | params = params | ||
319 : | } | ||
320 : | end | ||
321 : | (* end case *)) | ||
322 : | in | ||
323 : | insertInBase (catName, X.Category{ | ||
324 : | name = catName, | ||
325 : | functs = (List.map update baseFuns) @ newFns | ||
326 : | }) | ||
327 : | end | ||
328 : | | NONE => insertInBase (catName, cat) | ||
329 : | (* end case *)) | ||
330 : | in | ||
331 : | ATbl.app extend ext | ||
332 : | end | ||
333 : | |||
334 : | (* extend the first database with any additional definitions, etc. that | ||
335 : | * are provided by the second database. | ||
336 : | *) | ||
337 : | fun extend (DB base, DB ext) = ( | ||
338 : | (* NOTE: maybe we should allow different spec files? *) | ||
339 : | (* check that the two databases are compatible *) | ||
340 : | if (#specfile base <> #specfile ext) | ||
341 : | then conflict["spec files do not match"] | ||
342 : | else (); | ||
343 : | (* extend the database tables *) | ||
344 : | extendConstants (#constants base, #constants ext); | ||
345 : | extendTypes (#types base, #types ext); | ||
346 : | extendFuncts (#functions base, #functions ext)) | ||
347 : | |||
348 : | end |
root@smlnj-gforge.cs.uchicago.edu | ViewVC Help |
Powered by ViewVC 1.0.0 |