Home My Page Projects Code Snippets Project Openings 3D graphics for Standard ML
Summary Activity SCM

SCM Repository

[sml3d] Diff of /trunk/sml3d/gen/gen-from-xml/gldb/db.sml
ViewVC logotype

Diff of /trunk/sml3d/gen/gen-from-xml/gldb/db.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1399, Thu Apr 10 15:03:10 2014 UTC revision 1400, Thu Apr 10 15:39:46 2014 UTC
# Line 63  Line 63 
63              | _ => false              | _ => false
64            (* end case *))            (* end case *))
65    
66      fun sortTableItems tbl = let      fun sortItems keyItemPairList = let
67            fun gt ((key1, _), (key2, _)) = atomGT(key1, key2)            fun gt ((key1, _), (key2, _)) = atomGT(key1, key2)
68            in            in
69              List.map #2 (ListMergeSort.sort gt (ATbl.listItemsi tbl))              List.map #2 (ListMergeSort.sort gt keyItemPairList)
70            end            end
71    
72        fun sortTableItems tbl = sortItems (ATbl.listItemsi tbl)
73    
74      fun toXML (DB content) = X.DB{      fun toXML (DB content) = X.DB{
75              registry = #registry content,              registry = #registry content,
76              api = #api content,              api = #api content,
# Line 203  Line 205 
205      fun extendCommands (base, ext) = let      fun extendCommands (base, ext) = let
206            val findInBase = ATbl.find base            val findInBase = ATbl.find base
207            val insertInBase = ATbl.insert base            val insertInBase = ATbl.insert base
208              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            fun extend (cmd as X.Cmd{name, remove, protos}) = (            fun extend (cmd as X.Cmd{name, remove, protos}) = (
214                  case findInBase name                  case findInBase name
215                   of SOME(X.Cmd{protos=protos', ...}) => let                   of SOME(X.Cmd{protos=protos', ...}) => let
216  (* FIXME: extend remove *)  (* FIXME: extend remove *)
217                      (* we need to add any new prototypes into the existing list.  Note that for                      (* we need to add any new prototypes into the existing list.  We also
218                       * the expected usage of the extend function, the "ext" table will not add                       * need to add mltype attributes, when they are provided by the extension,
219                       * prototypes, just commands.                       * but not the base.
220                       *)                       *)
221                        val protoSet = let (* set of base prototypes *)                        val baseProtos = mkProtoMap protos'
222                              fun ins (X.Proto{name, ...}, m) = ASet.add(m, name)                        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                              in                              in
239                                List.foldl ins ASet.empty protos'                                X.Proto{
240                                      name = #name baseProto,
241                                      retTy = retTy,
242                                      params = ListPair.mapEq extParam (#params baseProto, #params extProto)
243                                    }
244                              end                              end
245  (* NOTE: we may want to add a consistency check for the overlapping definitions! *)  (* NOTE: we may want to add a consistency check for the overlapping definitions! *)
246                        val newProtos = List.filter                      (* merge and sort the prototypes *)
247                              (fn (X.Proto{name, ...}) => not(ASet.member(protoSet, name)))                        val protos = sortItems (
248                                protos                              AtomMap.listItemsi (
249                        in                                AtomMap.unionWith merge (baseProtos, extProtos)))
250                          if List.null newProtos                        in
251                            then ()                          insertInBase(name, X.Cmd{name=name, remove=remove, protos=protos})
                           else insertInBase(name, X.Cmd{name=name, remove=remove, protos=protos' @ newProtos})  
252                        end                        end
253                    | NONE => insertInBase(name, cmd)                    | NONE => insertInBase(name, cmd)
254                  (* end case *))                  (* end case *))

Legend:
Removed from v.1399  
changed lines
  Added in v.1400

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