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 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