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

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