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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 874 - (view) (download)

1 : blume 828 (*
2 :     * ast-to-spec.sml - Conversion from CKIT "ast" to a "spec" (see spec.sml).
3 :     *
4 :     * (C) 2001, Lucent Technologies, Bell Labs
5 :     *
6 :     * author: Matthias Blume (blume@research.bell-labs.com)
7 :     *)
8 :     structure AstToSpec = struct
9 :    
10 :     structure A = Ast
11 :     structure B = Bindings
12 :    
13 : blume 846 exception VoidType
14 : blume 873 exception Ellipsis
15 : blume 846
16 : blume 828 fun bug m = raise Fail ("AstToSpec: bug: " ^ m)
17 :     fun err m = raise Fail ("AstToSpec: error: " ^ m)
18 :     fun warn m = TextIO.output (TextIO.stdErr, "AstToSpec: warning: " ^ m)
19 :    
20 : blume 840 fun build (bundle, sizes: Sizes.sizes, idlfile, allSU, eshift) = let
21 : blume 873
22 : blume 874 val curLoc = ref "?"
23 :    
24 : blume 873 val errorState = Error.mkErrState TextIO.stdErr
25 :    
26 : blume 874 fun warnLoc m = warn (concat [!curLoc, ": ", m])
27 : blume 873
28 : blume 828 val { ast, tidtab, errorCount, warningCount,
29 :     auxiliaryInfo = { aidtab, implicits, env } } = bundle
30 :    
31 :     fun isThisFile SourceMap.UNKNOWN = false
32 :     | isThisFile (SourceMap.LOC { srcFile, ... }) = srcFile = idlfile
33 :    
34 :     fun isPublicName "" = false
35 :     | isPublicName n = String.sub (n, 0) <> #"_"
36 :    
37 :     fun includedSU (tag, loc) =
38 :     (allSU orelse isThisFile loc) andalso isPublicName tag
39 :    
40 :     fun includedTy (n, loc) = isThisFile loc andalso isPublicName n
41 :    
42 :     fun isFunction t = TypeUtil.isFunction tidtab t
43 :     fun getFunction t = TypeUtil.getFunction tidtab t
44 :     fun getCoreType t = TypeUtil.getCoreType tidtab t
45 :    
46 :     fun constness t =
47 :     if TypeUtil.isConst tidtab t then Spec.RO
48 :     else case getCoreType t of
49 :     A.Array (_, t) => constness t
50 :     | _ => Spec.RW
51 :    
52 : blume 873 val sizerec = { sizes = sizes, err = err, warn = warn, bug = bug }
53 : blume 828
54 :     fun sizeOf t = #bytes (Sizeof.byteSizeOf sizerec tidtab t)
55 :    
56 :     val bytebits = #bits (#char sizes)
57 :     val intbits = #bits (#int sizes)
58 :     val intalign = #align (#int sizes)
59 :    
60 :     fun getField (m, l) = Sizeof.getField sizerec (m, l)
61 :    
62 :     fun fieldOffsets t =
63 :     case Sizeof.fieldOffsets sizerec tidtab t of
64 :     NONE => bug "no field offsets"
65 :     | SOME l => l
66 :    
67 :     val structs = ref []
68 :     val unions = ref []
69 :     val gtys = ref []
70 :     val gvars = ref []
71 :     val gfuns = ref []
72 :    
73 :     val seen_structs = ref []
74 :     val seen_unions = ref []
75 :    
76 :     val nexttag = ref 0
77 :     val tags = Tidtab.uidtab () : string Tidtab.uidtab
78 :    
79 :     fun tagname (NONE, tid) =
80 :     (case Tidtab.find (tags, tid) of
81 :     SOME s => s
82 :     | NONE => let
83 :     val i = !nexttag
84 :     val s = Int.toString i
85 :     in
86 :     nexttag := i + 1;
87 :     Tidtab.insert (tags, tid, s);
88 :     s
89 :     end)
90 :     | tagname (SOME n, _) = n
91 :    
92 : blume 846 fun valty A.Void = raise VoidType
93 : blume 873 | valty A.Ellipses = raise Ellipsis
94 : blume 828 | valty (A.Qual (q, t)) = valty t
95 :     | valty (A.Numeric (_, _, A.SIGNED, A.CHAR, _)) = Spec.SCHAR
96 :     | valty (A.Numeric (_, _, A.UNSIGNED, A.CHAR, _)) = Spec.UCHAR
97 :     | valty (A.Numeric (_, _, A.SIGNED, A.INT, _)) = Spec.SINT
98 :     | valty (A.Numeric (_, _, A.UNSIGNED, A.INT, _)) = Spec.UINT
99 :     | valty (A.Numeric (_, _, A.SIGNED, A.SHORT, _)) = Spec.SSHORT
100 :     | valty (A.Numeric (_, _, A.UNSIGNED, A.SHORT, _)) = Spec.USHORT
101 :     | valty (A.Numeric (_, _, A.SIGNED, A.LONG, _)) = Spec.SLONG
102 :     | valty (A.Numeric (_, _, A.UNSIGNED, A.LONG, _)) = Spec.ULONG
103 :     | valty (A.Numeric (_, _, _, A.FLOAT, _)) = Spec.FLOAT
104 :     | valty (A.Numeric (_, _, _, A.DOUBLE, _)) = Spec.DOUBLE
105 :     | valty (A.Numeric _) = bug "numeric type not (yet) supported"
106 :     | valty (A.Array (NONE, t)) = valty (A.Pointer t)
107 :     | valty (A.Array (SOME (n, _), t)) =
108 :     Spec.ARR { t = valty t, d = Int.fromLarge n, esz = sizeOf t }
109 :     | valty (A.Pointer t) =
110 :     (case getCoreType t of
111 :     A.Void => Spec.VOIDPTR
112 :     | A.Function f => fptrty f
113 :     | _ => Spec.PTR (cobj t))
114 :     | valty (A.Function f) = fptrty f
115 :     | valty (A.StructRef tid) = typeref (tid, Spec.STRUCT)
116 :     | valty (A.UnionRef tid) = typeref (tid, Spec.UNION)
117 :     | valty (A.EnumRef tid) = typeref (tid, (* hack *) fn _ => Spec.SINT)
118 :     | valty (A.TypeRef tid) =
119 :     typeref (tid, fn _ => bug "missing typedef info")
120 :     | valty A.Error = err "Error type"
121 :    
122 : blume 873 and valty_nonvoid t = valty t
123 :     handle VoidType => err "void variable type"
124 : blume 846
125 : blume 828 and typeref (tid, otherwise) =
126 :     case Tidtab.find (tidtab, tid) of
127 :     NONE => bug "tid not bound in tidtab"
128 :     | SOME { name = SOME n, ntype = NONE, ... } => otherwise n
129 :     | SOME { name = NONE, ntype = NONE, ... } =>
130 :     bug "both name and ntype missing in tidtab binding"
131 :     | SOME { name, ntype = SOME nct, location, ... } =>
132 :     (case nct of
133 :     B.Struct (tid, members) =>
134 :     structty (tid, name, members, location)
135 :     | B.Union (tid, members) =>
136 :     unionty (tid, name, members, location)
137 :     | B.Enum (tid, _) => Spec.SINT (* for now (hack) *)
138 :     | B.Typedef (_, t) => let
139 :     val res = valty t
140 :     val n =
141 :     case name of
142 :     NONE => bug "missing name in typedef"
143 :     | SOME n => n
144 :     fun sameName { name, spec } = name = n
145 :     in
146 :     if includedTy (n, location) then
147 :     case List.find sameName (!gtys) of
148 :     SOME _ => ()
149 :     | NONE =>
150 :     gtys := { name = n, spec = res } :: !gtys
151 :     else ();
152 :     res
153 :     end)
154 :    
155 :     and structty (tid, name, members, location) = let
156 :     val tag = tagname (name, tid)
157 :     val ty = Spec.STRUCT tag
158 :     in
159 :     case List.find (fn tag' => tag = tag') (!seen_structs) of
160 :     SOME _ => ()
161 :     | NONE =>
162 :     if includedSU (tag, location) then
163 :     let val _ = seen_structs := tag :: !seen_structs
164 :    
165 :     val fol = fieldOffsets (A.StructRef tid)
166 :     val ssize = sizeOf (A.StructRef tid)
167 :    
168 :     fun bfspec (offset, bits, shift, (c, t)) = let
169 :     val offset = offset
170 :     val bits = Word.fromLargeInt bits
171 : blume 840 val shift = eshift (shift, intbits, bits)
172 : blume 828 val r = { offset = offset,
173 :     constness = c,
174 :     bits = bits,
175 :     shift = shift }
176 :     in
177 :     case t of
178 :     Spec.UINT => Spec.UBF r
179 :     | Spec.SINT => Spec.SBF r
180 :     | _ => err "non-int bitfield"
181 :     end
182 :    
183 :     fun synthetic (synth, (_, false), _) = ([], synth)
184 :     | synthetic (synth, (endp, true), startp) =
185 :     if endp = startp then ([], synth)
186 :     else ([{ name = Int.toString synth,
187 :     spec = Spec.OFIELD
188 :     { offset = endp,
189 :     spec = (Spec.RW,
190 :     Spec.ARR { t = Spec.UCHAR,
191 :     d = startp - endp,
192 :     esz = 1 }),
193 :     synthetic = true } }],
194 :     synth+1)
195 :    
196 :     fun build ([], synth, gap) =
197 :     #1 (synthetic (synth, gap, ssize))
198 :     | build ((t, SOME m, NONE) :: rest, synth, gap) =
199 :     let val bitoff = #bitOffset (getField (m, fol))
200 :     val bytoff = bitoff div bytebits
201 :     val (filler, synth) =
202 :     synthetic (synth, gap, bytoff)
203 :     val endp = bytoff + sizeOf t
204 :     in
205 :     if bitoff mod bytebits <> 0 then
206 :     bug "non-bitfield not on byte boundary"
207 :     else
208 :     filler @
209 :     { name = Symbol.name (#name m),
210 :     spec = Spec.OFIELD
211 :     { offset = bytoff,
212 :     spec = cobj t,
213 :     synthetic = false } } ::
214 :     build (rest, synth, (endp, false))
215 :     end
216 :     | build ((t, SOME m, SOME b) :: rest, synth, gap) =
217 :     let val bitoff = #bitOffset (getField (m, fol))
218 :     val bytoff =
219 :     (intalign * (bitoff div intalign))
220 :     div bytebits
221 :     val gap = (#1 gap, true)
222 :     in
223 :     { name = Symbol.name (#name m),
224 :     spec = bfspec (bytoff, b,
225 :     bitoff mod intalign,
226 :     cobj t) } ::
227 :     build (rest, synth, gap)
228 :     end
229 :     | build ((t, NONE, SOME _) :: rest, synth, gap) =
230 :     build (rest, synth, (#1 gap, true))
231 :     | build ((_, NONE, NONE) :: _, _, _) =
232 :     bug "unnamed struct member (not bitfield)"
233 :    
234 :     val fields = build (members, 0, (0, false))
235 :     in
236 :     structs := { tag = tag,
237 :     anon = not (isSome name),
238 :     size = Word.fromInt ssize,
239 :     fields = fields } :: !structs
240 :     end
241 :     else ();
242 :     ty
243 :     end
244 :    
245 :     and unionty (tid, name, members, location) = let
246 :     val tag = tagname (name, tid)
247 :     val ty = Spec.UNION tag
248 :     val lsz = ref 0
249 :     val lg = ref { name = "",
250 :     spec = Spec.OFIELD { offset = 0,
251 :     spec = (Spec.RW, Spec.SINT),
252 :     synthetic = true } }
253 :     fun mkField (t, m: A.member) = let
254 :     val sz = sizeOf t
255 :     val e = { name = Symbol.name (#name m),
256 :     spec = Spec.OFIELD { offset = 0,
257 :     spec = cobj t,
258 :     synthetic = false } }
259 :     in
260 :     if sz > !lsz then (lsz := sz; lg := e) else ();
261 :     e
262 :     end
263 :     in
264 :     case List.find (fn tag' => tag = tag') (!seen_unions) of
265 :     SOME _ => ()
266 :     | NONE =>
267 :     if includedSU (tag, location) then
268 :     let val _ = seen_unions := tag :: !seen_unions
269 :     val all = map mkField members
270 :     in
271 :     unions := { tag = tag,
272 :     anon = not (isSome name),
273 :     size = Word.fromInt
274 :     (sizeOf (A.UnionRef tid)),
275 :     largest = !lg,
276 :     all = all } :: !unions
277 :     end
278 :     else ();
279 :     ty
280 :     end
281 :    
282 : blume 846 and cobj t = (constness t, valty_nonvoid t)
283 : blume 828
284 :     and fptrty f = Spec.FPTR (cft f)
285 :    
286 :     and cft (res, args) =
287 :     { res = case getCoreType res of
288 :     A.Void => NONE
289 : blume 846 | _ => SOME (valty_nonvoid res),
290 : blume 828 args = case args of
291 :     [arg] => (case getCoreType arg of
292 :     A.Void => []
293 : blume 846 | _ => [valty_nonvoid arg])
294 : blume 874 | _ => let fun build [] = []
295 :     | build [x] =
296 :     ([valty_nonvoid x]
297 :     handle Ellipsis =>
298 :     (warnLoc
299 :     ("varargs not supported; \
300 :     \ignoring the ellipsis\n");
301 :     []))
302 :     | build (x :: xs) =
303 :     valty_nonvoid x :: build xs
304 :     in
305 :     build args
306 :     end }
307 : blume 828
308 :     fun functionName (f: A.id) = let
309 :     val n = Symbol.name (#name f)
310 :     in
311 :     if n = "_init" orelse n = "_fini" orelse
312 :     List.exists (fn { name, ... } => name = n) (!gfuns) then ()
313 :     else case #stClass f of
314 :     (A.EXTERN | A.DEFAULT) =>
315 :     (case getFunction (#ctype f) of
316 :     SOME fs =>
317 :     gfuns := { name = n, spec = cft fs } :: !gfuns
318 :     | NONE => bug "function without function type")
319 :     | (A.AUTO | A.REGISTER | A.STATIC) => ()
320 :     end
321 :    
322 :     fun varDecl (v: A.id) =
323 :     case #stClass v of
324 :     (A.EXTERN | A.DEFAULT) =>
325 :     if isFunction (#ctype v) then
326 :     functionName v
327 :     else let val n = Symbol.name (#name v)
328 :     in
329 :     if List.exists
330 :     (fn { name, ... } => name = n)
331 :     (!gvars) then ()
332 :     else
333 :     gvars := { name = n,
334 :     spec = cobj (#ctype v) } :: !gvars
335 :     end
336 :     | (A.AUTO | A.REGISTER | A.STATIC) => ()
337 :    
338 :     fun declaration (A.TypeDecl { tid, ... }) =
339 : blume 836 (* Spec.SINT is an arbitrary choice; the value gets
340 :     * ignored anyway *)
341 : blume 846 (ignore (typeref (tid, fn _ => Spec.SINT))
342 :     handle VoidType => ()) (* ignore type aliases for void *)
343 : blume 828 | declaration (A.VarDecl (v, _)) = varDecl v
344 :    
345 :     fun coreExternalDecl (A.ExternalDecl d) = declaration d
346 :     | coreExternalDecl (A.FunctionDef (f, _, _)) = functionName f
347 :     | coreExternalDecl (A.ExternalDeclExt _) = ()
348 :    
349 :     fun externalDecl (A.DECL (d, _, l)) =
350 : blume 874 if isThisFile l then (curLoc := SourceMap.locToString l;
351 :     coreExternalDecl d)
352 : blume 873 else ()
353 : blume 828
354 :     fun doast l = app externalDecl l
355 :     in
356 :     doast ast;
357 :     { structs = !structs,
358 :     unions = !unions,
359 :     gtys = !gtys,
360 :     gvars = !gvars,
361 :     gfuns = !gfuns }
362 :     end
363 :     end

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