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

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