Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/ml-nlffigen/ast-to-spec.sml
ViewVC logotype

Diff of /sml/trunk/src/ml-nlffigen/ast-to-spec.sml

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

revision 1061, Tue Feb 12 22:21:13 2002 UTC revision 1062, Wed Feb 13 21:15:14 2002 UTC
# Line 10  Line 10 
10      structure A = Ast      structure A = Ast
11      structure B = Bindings      structure B = Bindings
12    
13      structure SM = RedBlackMapFn (type ord_key = string      structure SS = StringSet
14                                    val compare = String.compare)      structure SM = StringMap
15    
16        datatype context = CONTEXT of { gensym: unit -> string, anon: bool }
17    
18      exception VoidType      exception VoidType
19      exception Ellipsis      exception Ellipsis
# Line 46  Line 48 
48              List.exists (fn f => f = srcFile) cfiles orelse              List.exists (fn f => f = srcFile) cfiles orelse
49              match srcFile              match srcFile
50    
51  (*          fun includedSU (tag, loc) = (allSU orelse isThisFile loc)
         fun isPublicName "" = false  
           | isPublicName n = String.sub (n, 0) <> #"_"  
 *)  
   
         fun includedSU (tag, loc) =  
             (allSU orelse isThisFile loc) (* andalso isPublicName tag *)  
52    
53          fun includedTy (n, loc) = isThisFile loc (* andalso isPublicName n *)          fun includedTy (n, loc) = isThisFile loc
54    
55          fun isFunction t = TypeUtil.isFunction tidtab t          fun isFunction t = TypeUtil.isFunction tidtab t
56          fun getFunction t = TypeUtil.getFunction tidtab t          fun getFunction t = TypeUtil.getFunction tidtab t
# Line 83  Line 79 
79    
80          val structs = ref []          val structs = ref []
81          val unions = ref []          val unions = ref []
82          val gtys = ref []          val gtys = ref SM.empty
83          val gvars = ref []          val gvars = ref SM.empty
84          val gfuns = ref []          val gfuns = ref SM.empty
85          val enums = ref SM.empty          val enums = ref SM.empty
86    
87          val seen_structs = ref []          val seen_structs = ref SS.empty
88          val seen_unions = ref []          val seen_unions = ref SS.empty
89    
90          val nexttag = ref 0          val nexttag = ref 0
91          val tags = Tidtab.uidtab () : string Tidtab.uidtab          val tags = Tidtab.uidtab () : (string * bool) Tidtab.uidtab
92    
93            fun mk_context_td tdname =
94                let val next = ref 0
95                in
96                    CONTEXT
97                        { gensym =
98                          fn () => let
99                                 val n = !next
100                             in
101                                 next := n + 1;
102                                 concat ["'",
103                                         if n = 0 then "" else Int.toString n,
104                                         tdname]
105                             end,
106                          anon = false }
107                end
108    
109            fun mk_context_su (parent_tag, anon) =
110                let val next = ref 0
111                in
112                    CONTEXT { gensym =
113                              fn () => let
114                                     val n = !next
115                                 in
116                                     next := n + 1;
117                                     concat [parent_tag, "'", Int.toString n]
118                                 end,
119                              anon = anon }
120                end
121    
122          fun tagname (NONE, NONE, tid) =          val tl_context =
123                let val next = ref 0
124                in
125                    CONTEXT { gensym =
126                              fn () => let
127                                     val n = !next
128                                 in
129                                     next := n + 1;
130                                     Int.toString n
131                                 end,
132                              anon = true }
133                end
134    
135            fun tagname (SOME t, _, _) = (t, false)
136              | tagname (NONE, CONTEXT { gensym, anon }, tid) =
137              (case Tidtab.find (tags, tid) of              (case Tidtab.find (tags, tid) of
138                   SOME s => s                   SOME ta => ta
139                 | NONE => let                 | NONE => let
140                       val i = !nexttag                       val t = gensym ()
                      val s = Int.toString i ^ gensym_suffix  
141                   in                   in
142                       nexttag := i + 1;                       Tidtab.insert (tags, tid, (t, anon));
143                       Tidtab.insert (tags, tid, s);                       (t, anon)
                      s  
144                   end)                   end)
           | tagname (NONE, SOME n, _) = "'" ^ n  
           | tagname (SOME n, _, _) = n  
145    
146          fun valty A.Void = raise VoidType          fun reported_tagname (t, false) = t
147            | valty A.Ellipses = raise Ellipsis            | reported_tagname (t, true) = t ^ gensym_suffix
148            | valty (A.Qual (q, t)) = valty t  
149            | valty (A.Numeric (_, _, A.SIGNED, A.CHAR, _)) = Spec.SCHAR          fun valty C A.Void = raise VoidType
150            | valty (A.Numeric (_, _, A.UNSIGNED, A.CHAR, _)) = Spec.UCHAR            | valty C A.Ellipses = raise Ellipsis
151            | valty (A.Numeric (_, _, A.SIGNED, A.INT, _)) = Spec.SINT            | valty C (A.Qual (q, t)) = valty C t
152            | valty (A.Numeric (_, _, A.UNSIGNED, A.INT, _)) = Spec.UINT            | valty C (A.Numeric (_, _, A.SIGNED, A.CHAR, _)) = Spec.SCHAR
153            | valty (A.Numeric (_, _, A.SIGNED, A.SHORT, _)) = Spec.SSHORT            | valty C (A.Numeric (_, _, A.UNSIGNED, A.CHAR, _)) = Spec.UCHAR
154            | valty (A.Numeric (_, _, A.UNSIGNED, A.SHORT, _)) = Spec.USHORT            | valty C (A.Numeric (_, _, A.SIGNED, A.INT, _)) = Spec.SINT
155            | valty (A.Numeric (_, _, A.SIGNED, A.LONG, _)) = Spec.SLONG            | valty C (A.Numeric (_, _, A.UNSIGNED, A.INT, _)) = Spec.UINT
156            | valty (A.Numeric (_, _, A.UNSIGNED, A.LONG, _)) = Spec.ULONG            | valty C (A.Numeric (_, _, A.SIGNED, A.SHORT, _)) = Spec.SSHORT
157            | valty (A.Numeric (_, _, _, A.FLOAT, _)) = Spec.FLOAT            | valty C (A.Numeric (_, _, A.UNSIGNED, A.SHORT, _)) = Spec.USHORT
158            | valty (A.Numeric (_, _, _, A.DOUBLE, _)) = Spec.DOUBLE            | valty C (A.Numeric (_, _, A.SIGNED, A.LONG, _)) = Spec.SLONG
159            | valty (A.Numeric _) = bug "numeric type not (yet) supported"            | valty C (A.Numeric (_, _, A.UNSIGNED, A.LONG, _)) = Spec.ULONG
160            | valty (A.Array (NONE, t)) = valty (A.Pointer t)            | valty C (A.Numeric (_, _, _, A.FLOAT, _)) = Spec.FLOAT
161            | valty (A.Array (SOME (n, _), t)) =            | valty C (A.Numeric (_, _, _, A.DOUBLE, _)) = Spec.DOUBLE
162              | valty C (A.Numeric _) = bug "numeric type not (yet) supported"
163              | valty C (A.Array (NONE, t)) = valty C (A.Pointer t)
164              | valty C (A.Array (SOME (n, _), t)) =
165              let val d = Int.fromLarge n              let val d = Int.fromLarge n
166              in              in
167                  if d < 0 then err "negative dimension"                  if d < 0 then err "negative dimension"
168                  else Spec.ARR { t = valty t, d = d, esz = sizeOf t }                  else Spec.ARR { t = valty C t, d = d, esz = sizeOf t }
169              end              end
170            | valty (A.Pointer t) =            | valty C (A.Pointer t) =
171              (case getCoreType t of              (case getCoreType t of
172                   A.Void => Spec.VOIDPTR                   A.Void => Spec.VOIDPTR
173                 | A.Function f => fptrty f                 | A.Function f => fptrty C f
174                 | _ => Spec.PTR (cobj t))                 | _ => Spec.PTR (cobj C t))
175            | valty (A.Function f) = fptrty f            | valty C (A.Function f) = fptrty C f
176            | valty (A.StructRef tid) = typeref (tid, Spec.STRUCT, NONE)            | valty C (A.StructRef tid) = typeref (tid, Spec.STRUCT, C)
177            | valty (A.UnionRef tid) = typeref (tid, Spec.UNION, NONE)            | valty C (A.UnionRef tid) = typeref (tid, Spec.UNION, C)
178            | valty (A.EnumRef tid) =            | valty C (A.EnumRef tid) =
179              typeref (tid, (* hack *) fn _ => Spec.SINT, NONE)              typeref (tid, (* hack *) fn _ => Spec.SINT, C)
180            | valty (A.TypeRef tid) =            | valty C (A.TypeRef tid) =
181              typeref (tid, fn _ => bug "missing typedef info", NONE)              typeref (tid, fn _ => bug "missing typedef info", C)
182            | valty A.Error = err "Error type"            | valty C A.Error = err "Error type"
183    
184          and valty_nonvoid t = valty t          and valty_nonvoid C t = valty C t
185              handle VoidType => err "void variable type"              handle VoidType => err "void variable type"
186    
187    (*
188          and valty_td (A.StructRef tid, tdname) =          and valty_td (A.StructRef tid, tdname) =
189              typeref (tid, Spec.STRUCT, tdname)              typeref (tid, Spec.STRUCT, tdname)
190            | valty_td (A.UnionRef tid, tdname) =            | valty_td (A.UnionRef tid, tdname) =
# Line 153  Line 192 
192            | valty_td (A.EnumRef tid, tdname) =            | valty_td (A.EnumRef tid, tdname) =
193              typeref (tid, fn _ => Spec.SINT, tdname)              typeref (tid, fn _ => Spec.SINT, tdname)
194            | valty_td (t, _) = valty t            | valty_td (t, _) = valty t
195    *)
196    
197          and typeref (tid, otherwise, tdname) =          and typeref (tid, otherwise, C) =
198              case Tidtab.find (tidtab, tid) of              case Tidtab.find (tidtab, tid) of
199                  NONE => bug "tid not bound in tidtab"                  NONE => bug "tid not bound in tidtab"
200                | SOME { name = SOME n, ntype = NONE, ... } => otherwise n                | SOME { name = SOME n, ntype = NONE, ... } => otherwise n
# Line 163  Line 203 
203                | SOME { name, ntype = SOME nct, location, ... } =>                | SOME { name, ntype = SOME nct, location, ... } =>
204                  (case nct of                  (case nct of
205                       B.Struct (tid, members) =>                       B.Struct (tid, members) =>
206                       structty (tid, name, tdname, members, location)                       structty (tid, name, C, members, location)
207                     | B.Union (tid, members) =>                     | B.Union (tid, members) =>
208                       unionty (tid, name, tdname, members, location)                       unionty (tid, name, C, members, location)
209                     | B.Enum (tid, edefs) => let                     | B.Enum (tid, edefs) => let
210                           fun one ({ name, uid, location, ctype, kind }, i) =                           fun one ({ name, uid, location, ctype, kind }, i) =
211                               { name = Symbol.name name, spec = i }                               { name = Symbol.name name, spec = i }
212                           val all = map one edefs                           val all = map one edefs
213                           val tn = tagname (name, tdname, tid)                           val (tn, anon) = tagname (name, C, tid)
214                             val rtn = reported_tagname (tn, anon)
215                       in                       in
216                           enums := SM.insert (!enums, tn,                           enums := SM.insert (!enums, rtn,
217                                               { src = srcOf location,                                               { src = srcOf location,
218                                                 tag = tn,                                                 tag = rtn,
219                                                 spec = all });                                                 spec = all });
220                           Spec.SINT                           Spec.SINT
221                       end                       end
# Line 183  Line 224 
224                               case name of                               case name of
225                                   NONE => bug "missing name in typedef"                                   NONE => bug "missing name in typedef"
226                                 | SOME n => n                                 | SOME n => n
227                           val res = valty_td (t, SOME n)                           val C' = mk_context_td n
228                             val res = valty C' t
229                           fun sameName { src, name, spec } = name = n                           fun sameName { src, name, spec } = name = n
230                       in                       in
231                           if includedTy (n, location) then                           if includedTy (n, location) andalso
232                               case List.find sameName (!gtys) of                              not (SM.inDomain (!gtys, n)) then
233                                   SOME _ => ()                               gtys := SM.insert (!gtys, n,
234                                 | NONE =>                                                  { src = srcOf location,
235                                   gtys := { src = srcOf location,                                                    name = n, spec = res })
                                            name = n, spec = res } :: !gtys  
236                           else ();                           else ();
237                           res                           res
238                       end)                       end)
239    
240          and structty (tid, name, tdname, members, location) = let          and structty (tid, name, C, members, location) = let
241              val tag = tagname (name, tdname, tid)              val (tag_stem, anon) = tagname (name, C, tid)
242                val tag = reported_tagname (tag_stem, anon)
243              val ty = Spec.STRUCT tag              val ty = Spec.STRUCT tag
244                val C' = mk_context_su (tag_stem, anon)
245          in          in
246              case List.find (fn tag' => tag = tag') (!seen_structs) of              if SS.member (!seen_structs, tag) then ()
247                  SOME _ => ()              else let
248                | NONE => let                      val _ = seen_structs := SS.add (!seen_structs, tag)
                     val _ = seen_structs := tag :: !seen_structs  
249    
250                      val fol = fieldOffsets (A.StructRef tid)                      val fol = fieldOffsets (A.StructRef tid)
251                      val ssize = sizeOf (A.StructRef tid)                      val ssize = sizeOf (A.StructRef tid)
# Line 252  Line 294 
294                                  { name = Symbol.name (#name m),                                  { name = Symbol.name (#name m),
295                                    spec = Spec.OFIELD                                    spec = Spec.OFIELD
296                                               { offset = bytoff,                                               { offset = bytoff,
297                                                 spec = cobj t,                                                 spec = cobj C' t,
298                                                 synthetic = false } } ::                                                 synthetic = false } } ::
299                                  build (rest, synth, (endp, false))                                  build (rest, synth, (endp, false))
300                          end                          end
# Line 266  Line 308 
308                              { name = Symbol.name (#name m),                              { name = Symbol.name (#name m),
309                                spec = bfspec (bytoff, b,                                spec = bfspec (bytoff, b,
310                                               bitoff mod intalign,                                               bitoff mod intalign,
311                                               cobj t) } ::                                               cobj C' t) } ::
312                              build (rest, synth, gap)                              build (rest, synth, gap)
313                          end                          end
314                        | build ((t, NONE, SOME _) :: rest, synth, gap) =                        | build ((t, NONE, SOME _) :: rest, synth, gap) =
# Line 278  Line 320 
320                  in                  in
321                      structs := { src = srcOf location,                      structs := { src = srcOf location,
322                                   tag = tag,                                   tag = tag,
323                                   anon = not (isSome name),                                   anon = anon,
324                                   size = Word.fromInt ssize,                                   size = Word.fromInt ssize,
325                                   exclude = not (includedSU (tag, location)),                                   exclude = not (includedSU (tag, location)),
326                                   fields = fields } :: !structs                                   fields = fields } :: !structs
# Line 286  Line 328 
328              ty              ty
329          end          end
330    
331          and unionty (tid, name, tdname, members, location) = let          and unionty (tid, name, C, members, location) = let
332              val tag = tagname (name, tdname, tid)              val (tag_stem, anon) = tagname (name, C, tid)
333                val tag = reported_tagname (tag_stem, anon)
334                val C' = mk_context_su (tag_stem, anon)
335              val ty = Spec.UNION tag              val ty = Spec.UNION tag
336              val lsz = ref 0              val lsz = ref 0
337              val lg = ref { name = "",              val lg = ref { name = "",
# Line 298  Line 342 
342                  val sz = sizeOf t                  val sz = sizeOf t
343                  val e = { name = Symbol.name (#name m),                  val e = { name = Symbol.name (#name m),
344                            spec = Spec.OFIELD { offset = 0,                            spec = Spec.OFIELD { offset = 0,
345                                                 spec = cobj t,                                                 spec = cobj C' t,
346                                                 synthetic = false } }                                                 synthetic = false } }
347              in              in
348                  if sz > !lsz then (lsz := sz; lg := e) else ();                  if sz > !lsz then (lsz := sz; lg := e) else ();
349                  e                  e
350              end              end
351          in          in
352              case List.find (fn tag' => tag = tag') (!seen_unions) of              if SS.member (!seen_unions, tag) then ()
353                  SOME _ => ()              else let
354                | NONE => let                      val _ = seen_unions := SS.add (!seen_unions, tag)
                     val _ = seen_unions := tag :: !seen_unions  
355                      val all = map mkField members                      val all = map mkField members
356                  in                  in
357                      unions := { src = srcOf location,                      unions := { src = srcOf location,
358                                  tag = tag,                                  tag = tag,
359                                  anon = not (isSome name),                                  anon = anon,
360                                  size = Word.fromInt (sizeOf (A.UnionRef tid)),                                  size = Word.fromInt (sizeOf (A.UnionRef tid)),
361                                  largest = !lg,                                  largest = !lg,
362                                  exclude = not (includedSU (tag, location)),                                  exclude = not (includedSU (tag, location)),
# Line 322  Line 365 
365              ty              ty
366          end          end
367    
368          and cobj t = (constness t, valty_nonvoid t)          and cobj C t = (constness t, valty_nonvoid C t)
369    
370          and fptrty f = Spec.FPTR (cft f)          and fptrty C f = Spec.FPTR (cft C f)
371    
372          and cft (res, args) =          and cft C (res, args) =
373              { res = case getCoreType res of              { res = case getCoreType res of
374                          A.Void => NONE                          A.Void => NONE
375                        | _ => SOME (valty_nonvoid res),                        | _ => SOME (valty_nonvoid C res),
376                args = case args of                args = case args of
377                           [(arg, _)] => (case getCoreType arg of                           [(arg, _)] => (case getCoreType arg of
378                                         A.Void => []                                         A.Void => []
379                                       | _ => [valty_nonvoid arg])                                       | _ => [valty_nonvoid C arg])
380                         | _ => let fun build [] = []                         | _ => let fun build [] = []
381                                      | build [(x, _)] =                                      | build [(x, _)] =
382                                        ([valty_nonvoid x]                                        ([valty_nonvoid C x]
383                                         handle Ellipsis =>                                         handle Ellipsis =>
384                                                (warnLoc                                                (warnLoc
385                                                     ("varargs not supported; \                                                     ("varargs not supported; \
386                                                      \ignoring the ellipsis\n");                                                      \ignoring the ellipsis\n");
387                                                     []))                                                     []))
388                                      | build ((x, _) :: xs) =                                      | build ((x, _) :: xs) =
389                                        valty_nonvoid x :: build xs                                        valty_nonvoid C x :: build xs
390                                in                                in
391                                    build args                                    build args
392                                end }                                end }
# Line 360  Line 403 
403              val anlo = Option.map (map (Symbol.name o #name)) ailo              val anlo = Option.map (map (Symbol.name o #name)) ailo
404          in          in
405              if n = "_init" orelse n = "_fini" orelse              if n = "_init" orelse n = "_fini" orelse
406                 List.exists (fn { name, ... } => name = n) (!gfuns) then ()                 SM.inDomain (!gfuns, n) then ()
407              else case #stClass f of              else case #stClass f of
408                       (A.EXTERN | A.DEFAULT) =>                       (A.EXTERN | A.DEFAULT) =>
409                       (case getFunction (#ctype f) of                       (case getFunction (#ctype f) of
410                            SOME fs =>                            SOME fs =>
411                            gfuns := { src = !curLoc,                            gfuns := SM.insert (!gfuns, n,
412                                       name = n, spec = cft fs, argnames = anlo }                                                { src = !curLoc,
413                                     :: !gfuns                                                  name = n,
414                                                    spec = cft tl_context fs,
415                                                    argnames = anlo })
416                          | NONE => bug "function without function type")                          | NONE => bug "function without function type")
417                     | (A.AUTO | A.REGISTER | A.STATIC) => ()                     | (A.AUTO | A.REGISTER | A.STATIC) => ()
418          end          end
# Line 381  Line 426 
426                     | NONE =>                     | NONE =>
427                       let val n = Symbol.name (#name v)                       let val n = Symbol.name (#name v)
428                       in                       in
429                           if List.exists                           if SM.inDomain (!gvars, n) then ()
430                                  (fn { name, ... } => name = n)                           else gvars := SM.insert
431                                  (!gvars) then ()                                             (!gvars, n,
432                           else                                              { src = !curLoc, name = n,
433                               gvars := { src = !curLoc, name = n,                                                spec = cobj tl_context
434                                          spec = cobj (#ctype v) } :: !gvars                                                            (#ctype v) })
435                       end)                       end)
436                | (A.AUTO | A.REGISTER | A.STATIC) => ()                | (A.AUTO | A.REGISTER | A.STATIC) => ()
437    
438          fun declaration (A.TypeDecl { tid, ... }) =          fun declaration (A.TypeDecl { tid, ... }) =
439              (* Spec.SINT is an arbitrary choice; the value gets              (* Spec.SINT is an arbitrary choice; the value gets
440               * ignored anyway *)               * ignored anyway *)
441              (ignore (typeref (tid, fn _ => Spec.SINT, NONE))              (ignore (typeref (tid, fn _ => Spec.SINT, tl_context))
442               handle VoidType => ())     (* ignore type aliases for void *)               handle VoidType => ())     (* ignore type aliases for void *)
443            | declaration (A.VarDecl (v, _)) = varDecl v            | declaration (A.VarDecl (v, _)) = varDecl v
444    
# Line 412  Line 457 
457          doast ast;          doast ast;
458          { structs = !structs,          { structs = !structs,
459            unions = !unions,            unions = !unions,
460            gtys = !gtys,            gtys = SM.listItems (!gtys),
461            gvars = !gvars,            gvars = SM.listItems (!gvars),
462            gfuns = !gfuns,            gfuns = SM.listItems (!gfuns),
463            enums = SM.listItems (!enums) } : Spec.spec            enums = SM.listItems (!enums) } : Spec.spec
464      end      end
465  end  end

Legend:
Removed from v.1061  
changed lines
  Added in v.1062

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