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