1: # 15 "./lpsrc/flx_flxcc.pak"
2: open List
3: open Flx_util
4: open Flx_types
5: open Flx_version
6: open Flx_mtypes1
7: open Flx_cil_cabs
8: open Flx_cil_cil
9: open Flxcc_util
10: ;;
11:
12: let force_open_in place f =
13: try
14: open_in f
15: with
16: | _ -> failwith ("[" ^ place ^ "] Can't open " ^ f ^ " for input")
17:
18: let force_open_out place f =
19: try
20: open_out f
21: with
22: | _ -> failwith ("[" ^ place ^ "] Can't open " ^ f ^ " for output")
23:
24: type stab_t = {
25: stab_cfile: string;
26: stab_flxfile: string;
27: stab_flxinclude: string;
28: stab_module: string;
29:
30: aliases: (string,string) Hashtbl.t;
31: struct_aliases: (string,string) Hashtbl.t;
32: abstract_types: (string,string) Hashtbl.t;
33: incomplete_types: (string,string) Hashtbl.t;
34: mutable xtyps: (string,string) Hashtbl.t;
35: mutable udt: (string,unit) Hashtbl.t;
36: mutable ict: (string,string) Hashtbl.t;
37: used_types: (string,unit) Hashtbl.t;
38: variables : (string,string) Hashtbl.t;
39: functions: (string * typsig list * string,string * string) Hashtbl.t;
40: fields: (string,string * string) Hashtbl.t;
41: cstructs : (string,(string * string) list) Hashtbl.t;
42: procedures: (string * typsig list * string,string * string) Hashtbl.t;
43: callback_types: (string,typ * int) Hashtbl.t;
44: callback_clients: (string,typ * string * int * int) Hashtbl.t;
45: enums: (string,string) Hashtbl.t;
46: registry: (typsig, string * string) Hashtbl.t;
47: mutable includes: StringSet.t;
48: counter: int ref
49: }
50: ;;
51:
52: let isprefix p s =
53: let pn = String.length p in
54: String.length s >= pn &&
55: String.sub s 0 pn = p
56: ;;
57:
58: exception Next
59: ;;
60: type control_t = {
61: mutable control_filename: string;
62: mutable flxg_command: string;
63: mutable prein_filename: string;
64: mutable preout_filename: string;
65: mutable log_filename: string;
66: mutable language: Flx_cil_cabs.lang_t;
67: mutable preprocessor: string;
68: mutable raw_includes: StringSet.t;
69: mutable raw_include_dirs : StringSet.t;
70: mutable include_path: string list;
71: mutable noincludes: string list;
72: mutable merge_files: (string * string) list;
73: mutable rev_merge_files: (string,string list) Hashtbl.t;
74: mutable outdir: string;
75: mutable repl_prefix: (string * string) list;
76: stabs : (string,stab_t) Hashtbl.t;
77: all_types : (string,string) Hashtbl.t;
78: incomplete_types_cache: (string,string * string list) Hashtbl.t;
79: mutable files: StringSet.t;
80: replacements : (string,string) Hashtbl.t;
81: nontype_replacements : (string,string) Hashtbl.t;
82: rejects: (string,unit) Hashtbl.t;
83: mutable root_includes: string list;
84: mutable root_rec_includes: string list;
85: mutable root_excludes : string list;
86: }
87: ;;
88:
89: let control = {
90: control_filename = Sys.argv.(1);
91: flxg_command = "";
92: prein_filename = Sys.argv.(1) ^ ".h";
93: preout_filename = Sys.argv.(1) ^ ".i";
94: log_filename = Sys.argv.(1) ^ ".log";
95: language = `C;
96: preprocessor ="cpp ";
97: noincludes = [];
98: raw_includes = StringSet.empty;
99: raw_include_dirs = StringSet.empty;
100: include_path = [];
101: merge_files = [];
102: rev_merge_files = Hashtbl.create 97;
103: outdir = "flxcc_out";
104: repl_prefix = [];
105: stabs = Hashtbl.create 97;
106: all_types = Hashtbl.create 97;
107: incomplete_types_cache = Hashtbl.create 97;
108: files = StringSet.empty;
109: replacements = Hashtbl.create 97;
110: nontype_replacements = Hashtbl.create 97;
111: rejects = Hashtbl.create 97;
112: root_rec_includes = [];
113: root_includes = [];
114: root_excludes = [];
115: }
116: ;;
117:
118: (* map the name of a #include file which is
119: intended to be a physical part of another
120: into that filename.
121:
122: The mapping is used to prevent
123: a Felix include file or module being
124: created for definitions in this file,
125: but it should *only* be used when a file
126: is uniquely included by another
127:
128: When we're scanning for includes,
129: we need all the physical (unmapped)
130: filenames as inputs to find the transitive
131: closure. Once that is done, the transitive
132: closure itself must be mapped to avoid
133: references to non-existent Felix modules.
134: *)
135:
136: let rec glob dir recurse level =
137: if not (mem dir control.root_excludes) then
138: let spaces = String.make level ' ' in
139: try
140: let f = Unix.opendir dir in
141: control.raw_include_dirs <- StringSet.add dir control.raw_include_dirs;
142: begin
143: try
144: while true do let m = Unix.readdir f in
145: let path = Filename.concat dir m in
146: let st =
147: try Unix.lstat path
148: with _ -> failwith ("Can't lstat " ^ path)
149: in
150: match st.Unix.st_kind with
151: | Unix.S_REG ->
152: if not (mem path control.root_excludes)
153: then begin
154: control.raw_includes <- StringSet.add path control.raw_includes;
155: control.files <- StringSet.add path control.files
156: end
157:
158: | Unix.S_DIR ->
159: if recurse then
160: if not (isprefix "." m) then
161: begin
162: glob path recurse (level + 1)
163: end
164:
165: | _ -> ()
166: done
167: with End_of_file -> Unix.closedir f
168: end
169: with Unix.Unix_error _ ->
170: failwith ("Can't find directory " ^ dir)
171: ;;
172:
173: let pattern = ref "*.h"
174: ;;
175:
176: let rec parse_control_file filename =
177: let f = force_open_in "parse_control_file" filename
178: in
179: let rec aux () =
180: try
181: let line = input_line f in
182: let n = String.length line in
183: let i = ref 0 in
184: try
185: (* skip white *)
186: while !i < n && line.[!i]=' ' do incr i done;
187: if !i = n then raise Next;
188:
189: (* detect C++ style comment *)
190: if isprefix "//" (String.sub line !i (n - !i))
191: then raise Next
192: ;
193: let j = !i in
194: while !i < n && line.[!i]<>' ' do incr i done;
195: let keyword = String.sub line j (!i-j) in
196:
197: match keyword with
198: | "#include" ->
199: while !i < n && line.[!i]=' ' do incr i done;
200: if !i = n then failwith "outdir statement requires filename";
201: let j = !i in
202: while !i < n && line.[!i]<>' ' do incr i done;
203: let fn = String.sub line j (!i-j) in
204: parse_control_file fn;
205: raise Next
206:
207: | "outdir" ->
208: while !i < n && line.[!i]=' ' do incr i done;
209: if !i = n then failwith "outdir statement requires filename";
210: let j = !i in
211: while !i < n && line.[!i]<>' ' do incr i done;
212: control.outdir <- String.sub line j (!i-j);
213: raise Next
214:
215: | "prein" ->
216: while !i < n && line.[!i]=' ' do incr i done;
217: if !i = n then failwith "prein statement requires filename";
218: let j = !i in
219: while !i < n && line.[!i]<>' ' do incr i done;
220: control.prein_filename <- String.sub line j (!i-j);
221: raise Next
222:
223: | "preout" ->
224: while !i < n && line.[!i]=' ' do incr i done;
225: if !i = n then failwith "preout statement requires filename";
226: let j = !i in
227: while !i < n && line.[!i]<>' ' do incr i done;
228: control.preout_filename <- String.sub line j (!i-j);
229: raise Next
230:
231: | "language" ->
232: while !i < n && line.[!i]=' ' do incr i done;
233: if !i = n then failwith "preout statement requires filename";
234: let j = !i in
235: while !i < n && line.[!i]<>' ' do incr i done;
236: let x = String.sub line j (!i-j) in
237: control.language <-
238: (
239: match x with
240: | "C" | "c" -> `C
241: | "C++" | "c++" | "cxx" -> `Cxx
242: | _ -> failwith ("Unknown language " ^ x ^", must be C or C++")
243: )
244: ;
245: raise Next
246:
247: | "flx_compiler" ->
248: while !i < n && line.[!i]=' ' do incr i done;
249: let j = !i in
250: while !i < n do incr i done;
251: control.flxg_command <- String.sub line j (!i-j);
252: raise Next
253:
254: | "preprocessor" ->
255: while !i < n && line.[!i]=' ' do incr i done;
256: if !i = n then failwith "preprocessor statement requires arguments";
257: let j = !i in
258: while !i < n do incr i done;
259: control.preprocessor <- String.sub line j (!i-j);
260: raise Next
261:
262: | "noheader" ->
263: while !i < n && line.[!i]=' ' do incr i done;
264: if !i = n then failwith "noinclude statement requires filename";
265: let j = !i in
266: while !i < n && line.[!i]<>' ' do incr i done;
267: let fn = String.sub line j (!i-j) in
268: control.noincludes <- fn :: control.noincludes;
269: raise Next
270:
271: | "incdir" ->
272: while !i < n && line.[!i]=' ' do incr i done;
273: if !i = n then failwith "incdir statement requires filename";
274: let j = !i in
275: while !i < n && line.[!i]<>' ' do incr i done;
276: let fn = String.sub line j (!i-j) in
277: control.root_includes <- fn :: control.root_includes;
278: raise Next
279:
280: | "incfile" ->
281: while !i < n && line.[!i]=' ' do incr i done;
282: if !i = n then failwith "incfile statement requires filename";
283: let j = !i in
284: while !i < n && line.[!i]<>' ' do incr i done;
285: let fn = String.sub line j (!i-j) in
286: control.raw_includes <- StringSet.add fn control.raw_includes;
287: raise Next
288:
289: | "recincdir" ->
290: while !i < n && line.[!i]=' ' do incr i done;
291: if !i = n then failwith "incdir statement requires filename";
292: let j = !i in
293: while !i < n && line.[!i]<>' ' do incr i done;
294: let fn = String.sub line j (!i-j) in
295: control.root_rec_includes <- fn :: control.root_rec_includes;
296: raise Next
297:
298: | "path" ->
299: while !i < n && line.[!i]=' ' do incr i done;
300: if !i = n then failwith "path statement requires filename";
301: let j = !i in
302: while !i < n && line.[!i]<>' ' do incr i done;
303: let fn = String.sub line j (!i-j) in
304: control.include_path <- control.include_path @ [fn];
305: raise Next
306:
307: | "exclude" ->
308: while !i < n && line.[!i]=' ' do incr i done;
309: if !i = n then failwith "exclude statement requires filename";
310: let j = !i in
311: while !i < n && line.[!i]<>' ' do incr i done;
312: let fn = String.sub line j (!i-j) in
313: control.root_excludes<- fn :: control.root_excludes;
314: raise Next
315:
316: | "prefix" ->
317: while !i < n && line.[!i]=' ' do incr i done;
318: if !i = n then failwith "prefix statement requires filename";
319: let j = !i in
320: while !i < n && line.[!i]<>' ' do incr i done;
321: let fn1 = String.sub line j (!i-j) in
322:
323: while !i < n && line.[!i]=' ' do incr i done;
324: let fn2 =
325: if !i = n then ""
326: else begin
327: let j = !i in
328: while !i < n && line.[!i]<>' ' do incr i done;
329: String.sub line j (!i-j)
330: end
331: in
332: control.repl_prefix <- (fn1, fn2) :: control.repl_prefix;
333: raise Next
334:
335: | "merge" ->
336: while !i < n && line.[!i]=' ' do incr i done;
337: if !i = n then failwith "merge statement requires filename";
338: let j = !i in
339: while !i < n && line.[!i]<>' ' do incr i done;
340: let fn1 = String.sub line j (!i-j) in
341:
342: while !i < n && line.[!i]=' ' do incr i done;
343: if !i = n then failwith "merge statement requires 2 filenames";
344: let j = !i in
345: while !i < n && line.[!i]<>' ' do incr i done;
346: let fn2 = String.sub line j (!i-j) in
347: control.merge_files <- (fn1,fn2) :: control.merge_files;
348: let x =
349: try Hashtbl.find control.rev_merge_files fn2
350: with Not_found -> []
351: in Hashtbl.replace control.rev_merge_files fn2 (fn1::x)
352: ;
353: raise Next
354:
355: | "rename" ->
356: while !i < n && line.[!i]=' ' do incr i done;
357: if !i = n then failwith "rename statement requires name";
358: let j = !i in
359: while !i < n && line.[!i]<>' ' do incr i done;
360: let fn1 = String.sub line j (!i-j) in
361:
362: while !i < n && line.[!i]=' ' do incr i done;
363: if !i = n then failwith "rename statement requires 2 names";
364: let j = !i in
365: while !i < n && line.[!i]<>' ' do incr i done;
366: let fn2 = String.sub line j (!i-j) in
367: Hashtbl.add control.replacements fn1 fn2;
368: raise Next
369:
370: | "rename_nontype" ->
371: while !i < n && line.[!i]=' ' do incr i done;
372: if !i = n then failwith "rename_nontype statement requires name";
373: let j = !i in
374: while !i < n && line.[!i]<>' ' do incr i done;
375: let fn1 = String.sub line j (!i-j) in
376:
377: while !i < n && line.[!i]=' ' do incr i done;
378: if !i = n then failwith "rename_nontype statement requires 2 names";
379: let j = !i in
380: while !i < n && line.[!i]<>' ' do incr i done;
381: let fn2 = String.sub line j (!i-j) in
382: Hashtbl.add control.nontype_replacements fn1 fn2;
383: raise Next
384:
385: | "ignore" ->
386: while !i < n && line.[!i]=' ' do incr i done;
387: if !i = n then failwith "ignore statement requires name";
388: let j = !i in
389: while !i < n && line.[!i]<>' ' do incr i done;
390: let fn = String.sub line j (!i-j) in
391: Hashtbl.add control.rejects fn ();
392: raise Next
393:
394: | _ -> failwith ("Unknown keyword " ^keyword^ " in control file")
395:
396: with Next -> aux()
397: with End_of_file -> ()
398: in
399: aux ();
400: close_in f
401: ;;
402: parse_control_file control.control_filename
403: ;;
404:
405: iter
406: (fun s -> glob s false 0)
407: control.root_includes
408: ;;
409:
410: iter
411: (fun s -> glob s true 0)
412: control.root_rec_includes
413: ;;
414:
415: let autocreate x =
416: try open_out x
417: with | _ ->
418: let rec mkpath x =
419: let d = Filename.dirname x in
420: if d <> "" then begin
421: try Unix.mkdir d 0o777
422: with _ ->
423: mkpath d;
424: try Unix.mkdir d 0o777
425: with _ -> failwith ("[autocreate] Can't create (p=0777) directory " ^ d)
426: end
427: in
428: mkpath x;
429: force_open_out "autocreate" x
430:
431: ;;
432:
433: let f = autocreate control.prein_filename in
434: StringSet.iter
435: (fun s ->
436: output_string f ("#include \"" ^ s ^ "\"\n")
437: )
438: control.raw_includes
439: ;
440: close_out f
441: ;;
442:
443: let precmd =
444: let path = ref "" in
445: (*
446: StringSet.iter
447: (fun s -> path := !path ^ "-I" ^ s ^ " ")
448: control.raw_include_dirs
449: ;
450: *)
451: path :=
452: (
453: String.concat " "
454: (
455: map
456: (fun s-> "-I"^s^" ")
457: control.include_path
458: )
459: ) ^ " " ^ !path
460: ;
461:
462: control.preprocessor ^ " " ^
463: !path ^ " " ^
464: control.prein_filename ^
465: " >" ^control.preout_filename
466: ;;
467:
468: print_endline "PREPROCESSOR COMMAND:";
469: print_endline precmd
470: ;;
471:
472: Unix.system precmd
473: ;;
474:
475: let format_time tm =
476: si (tm.Unix.tm_year + 1900) ^ "/" ^
477: si (tm.Unix.tm_mon + 1) ^ "/" ^
478: si tm.Unix.tm_mday ^ " " ^
479: si tm.Unix.tm_hour ^ ":" ^
480: si tm.Unix.tm_min ^ ":" ^
481: si tm.Unix.tm_sec
482: ;;
483:
484: let compile_start = Unix.time ()
485: let compile_start_gm = Unix.gmtime compile_start
486: let compile_start_local = Unix.localtime compile_start
487: let compile_start_gm_string = format_time compile_start_gm ^ " UTC"
488: let compile_start_local_string = format_time compile_start_local ^ " (local)"
489: ;;
490:
491: Flx_cil_cil.initCIL()
492: ;;
493:
494: let lexbuf = Flx_cil_clexer.init control.preout_filename control.language;;
495: let cabs = Flx_cil_cparser.file Flx_cil_clexer.initial lexbuf
496: ;;
497: Flx_cil_clexer.finish()
498: ;;
499:
500: (*
501: Flx_cil_cprint.print_defs cabs;;
502: *)
503:
504: let ns (s,_,_,_) = s
505: ;;
506: let is_def = function | Some _ -> "complete" | None -> "incomplete"
507: ;;
508: let type_of_se = function
509: | SpecType ts ->
510: begin match ts with
511: | Tnamed s -> print_endline ("type " ^ s)
512: | Tstruct (s,fglo,_) ->
513: print_endline ("struct " ^ s ^ " " ^ is_def fglo)
514: | Tunion (s,fglo,_) ->
515: print_endline ("union " ^ s ^ " " ^ is_def fglo)
516: | Tenum (s,fglo,_) ->
517: print_endline ("enum " ^ s ^ " " ^ is_def fglo)
518: | _ -> ()
519: end
520: | _ -> ()
521:
522: let types_in sp = List.iter type_of_se sp
523: ;;
524:
525: let cil = Flx_cil_cabs2cil.convFile (control.preout_filename, cabs)
526: ;;
527:
528:
529: (*
530: dumpFile defaultCilPrinter stdout cil ;;
531: *)
532:
533: let {fileName=f; globals=gs} = cil
534: ;;
535:
536: (* files not corresponding to a module *)
537: let excludes : string list ref = ref
538: [
539: ]
540: ;;
541:
542: let rpltname s =
543: try Hashtbl.find control.replacements s
544: with Not_found -> s
545:
546: let rplname s =
547: try Hashtbl.find control.nontype_replacements s
548: with Not_found ->
549: try Hashtbl.find control.replacements s
550: with Not_found -> s
551:
552: let strexp n = "0" (* cheat *)
553: ;;
554:
555: let remove_pnames t = match t with
556: | TPtr (TFun (t,Some ps,b,a),a') ->
557: let ps = map (fun (_,t,a)->"",t,a) ps in
558: TPtr (TFun (t,Some ps,b,a),a')
559: | _ -> t
560:
561: (* strip multiple spaces and newlines out *)
562: let reformatc s =
563: let s' = ref "" in
564: let n = String.length s in
565: for i=0 to n - 1 do
566: let
567: ch = s.[i] and
568: ch2 = if i < n-2 then s.[i+1] else '\000'
569: in
570: if
571: ch = ' ' &&
572: (ch2=' ' ||ch2=',' || ch2=';' || ch2=')' || ch2='\n')
573: then ()
574: else if ch='\n' then s' := !s' ^ " "
575: else s' := !s' ^ String.make 1 ch
576: done;
577: let n = ref (String.length !s' - 1) in
578: while !n >= 0 && !s'.[!n]=' ' do decr n done;
579: String.sub !s' 0 (!n+1)
580:
581: let choose_alias stab s =
582: let ss = ref [] in
583: begin try
584: let s' = Hashtbl.find stab.aliases s in
585: ss := s' :: !ss
586: with Not_found -> ()
587: end
588: ;
589:
590: begin try
591: let s' = Hashtbl.find stab.struct_aliases s in
592: ss := s' :: !ss
593: with Not_found -> ()
594: end
595: ;
596:
597: (* just pick the shortest name *)
598: let s = s :: !ss in
599: let s = map (fun x -> String.length x,x) s in
600: let s = sort compare s in
601: let _,p = hd s in
602: p
603:
604: let prefered_alias stab s = choose_alias stab s
605:
606:
607: let rec sot stab t = match t with
608: | TVoid a -> "void_t"
609: | TInt (ik,a) -> soi ik
610: | TFloat (fk,a) -> sof fk
611: | TPtr (TVoid a',a) -> (cvqual a')^"address"
612: | TPtr (TFun _,a) ->
613: let t' = typeSig t in
614: begin try
615: fst (Hashtbl.find stab.registry t')
616: with
617: Not_found ->
618: let name = stab.stab_module ^"_cft_" ^ si !(stab.counter) in
619: incr stab.counter;
620: let sr = locUnknown in
621: let t = remove_pnames t in
622: let si = {tname=name;ttype=t;treferenced=true } in
623: let gt = GType (si,sr) in
624: let d = defaultCilPrinter#pGlobal () gt in
625: let s = Flx_cil_pretty.sprint 65 d in
626: let s = reformatc s in
627: Hashtbl.add stab.registry t' (name,s);
628: name
629: end
630:
631: | TPtr (t',a) -> cvqual (attrof t') ^ "ptr[" ^ sot stab t'^ "]"
632: | TArray (t',Some n,a)->
633: cvqual (attrof t') ^ "ptr[" ^ sot stab t'^ "]"
634:
635: | TArray (t',None,a)->
636: cvqual (attrof t') ^ "ptr[" ^ sot stab t' ^ "]"
637:
638: | TFun (t',Some ps,false,a) ->
639: let ret = sot stab t'
640: and args =
641: if length ps = 0 then "1"
642: else String.concat " * " (List.map (soa stab) ps)
643: in args ^ " -> " ^ ret
644:
645: | TFun (t',None,false,a) ->
646: let ret = sot stab t'
647: and args = "1"
648: in args ^ " -> " ^ ret
649:
650: | TFun (t',_,_,a) -> "CANT HANDLE THIS FUN"
651:
652: | TNamed (ti,a) ->
653: let name = ptname ti in
654: let name = prefered_alias stab name in
655: Hashtbl.add stab.used_types name ();
656: rpltname name
657:
658: | TComp (ci,a) ->
659: let name = pci ci in
660: let name = prefered_alias stab name in
661: Hashtbl.add stab.used_types name ();
662: rpltname name
663:
664: | TEnum (ei,a) -> "int"
665: | TBuiltin_va_list a -> "__builtin_va_list"
666:
667: and ptdef registry ti:string = match ti with
668: {ttype=tt} -> sot registry tt
669:
670: and soa stab (name,t,a) = sot stab t
671:
672: and sov registry vi = match vi with
673: {vname=vname; vtype=vtype} ->
674: "const " ^ vname ^ ": " ^ sot registry vtype
675:
676: let pe x = print_endline x
677: ;;
678:
679: (* name with replacement *)
680: let flx_name x = match flx_name' x with
681: | Some x -> Some (rplname x)
682: | None -> None
683:
684: (* type name with replacement *)
685: let flx_tname x = match flx_name' x with
686: | Some x -> rpltname x
687: | None -> "error!!"
688:
689: let can_gen_ctype cstruct cfields = cstruct &&
690: fold_left
691: (fun t {fname=fname; ftype=ftype} ->
692: t && not (isanont ftype) && ispublic fname &&
693: is_cstruct_field ftype
694: )
695: true cfields
696:
697: let chop_extension f =
698: let b = Filename.basename f in
699: let d = Filename.dirname f in
700: let b = try Filename.chop_extension b with _ -> b in
701: if d = "." then b else Filename.concat d b
702:
703: let replace_prefix x ls =
704: let x = ref x in
705: iter
706: (fun (a,b) ->
707: if isprefix a !x then
708: let n = String.length a in
709: let m = String.length !x in
710: x := b ^ String.sub !x n (m-n)
711: )
712: ls
713: ;
714: !x
715: let map_filename f =
716: let f = replace_prefix f control.merge_files in
717: f
718:
719: let flxinclude_of_cfile cfilename =
720: let x = map_filename cfilename in
721: let x = replace_prefix x control.repl_prefix in
722: let x = chop_extension x ^ "_lib" in
723: let x = if isprefix "/" x then String.sub x 1 (String.length x - 1) else x in
724: let x = if isprefix "." x then String.sub x 1 (String.length x - 1) else x in
725: x
726:
727: let flxfile_of_cfile cfilename =
728: let base = flxinclude_of_cfile cfilename in
729: Filename.concat (control.outdir) (base ^ ".flx")
730:
731: let srepl s c1 c2 =
732: for i = 0 to String.length s - 1 do
733: if s.[i]=c1 then s.[i] <- c2
734: done
735: ;;
736:
737: let module_of_cfilename s =
738: let module_of_filename fname =
739: let x = String.copy fname in
740: let fixup x =
741: srepl x '.' '_';
742: srepl x ' ' '_';
743: srepl x '/' '_';
744: srepl x '-' '_';
745: srepl x '+' '_';
746: srepl x ':' '_';
747: in
748: let mname =
749: try
750: let x = (chop_extension x) in
751: let x =
752: let m = String.length x in
753: if m>0 && x.[0] = '/' then String.sub x 1 (m-1) else x
754: in
755: fixup x;
756: x ^ "_h"
757: with Invalid_argument _ ->
758: print_endline ("Weird (C++??) filename " ^ fname ^ " without extension");
759: fixup x;
760: x
761: in rplname mname (* apply user renaming to modules too *)
762: in
763: let s = map_filename s in
764: let s = replace_prefix s control.repl_prefix in
765: module_of_filename s
766:
767: ;;
768:
769: let mk_stab cfile =
770: {
771: stab_cfile = cfile;
772: stab_flxfile = flxfile_of_cfile cfile;
773: stab_flxinclude = flxinclude_of_cfile cfile;
774: stab_module = module_of_cfilename cfile;
775:
776: aliases= Hashtbl.create 97;
777: struct_aliases= Hashtbl.create 97;
778: abstract_types= Hashtbl.create 97;
779: incomplete_types= Hashtbl.create 97;
780: used_types= Hashtbl.create 97;
781: variables= Hashtbl.create 97;
782: functions= Hashtbl.create 97;
783: fields= Hashtbl.create 97;
784: cstructs = Hashtbl.create 97;
785: procedures= Hashtbl.create 97;
786: callback_types = Hashtbl.create 97;
787: callback_clients = Hashtbl.create 97;
788: enums= Hashtbl.create 97;
789: registry= Hashtbl.create 97;
790: includes = StringSet.empty;
791: xtyps = Hashtbl.create 97;
792: ict = Hashtbl.create 97;
793: udt = Hashtbl.create 97;
794: counter = ref 1
795: }
796: ;;
797:
798: let getstab s =
799: let lfn = map_filename s in
800: try Hashtbl.find control.stabs lfn
801: with Not_found ->
802: let x = mk_stab s in
803: Hashtbl.add control.stabs lfn x;
804: x
805:
806: let getreg {file=s} = getstab s
807:
808: let oplist = [
809: "+","add";
810: "-","sub";
811: "*","mul";
812: "/","div";
813: "%","mod";
814:
815: "<","lt";
816: ">","gt";
817: "<=","le";
818: ">=","ge";
819: "==","eq";
820: "!=","ne";
821:
822: "=","_set";
823:
824: "||","lor";
825: "&&","land";
826: "!","lnot";
827:
828: "^","bxor";
829: "|","bor";
830: "&","band";
831: "~","compl";
832:
833: "+=","pluseq";
834: "-=","minuseq";
835: "*=","muleq";
836: "/=","diveq";
837: "%=","modeq";
838: "^=","careteq";
839: "|=","vbareq";
840: "&=","ampereq";
841: "~=","tildeeq";
842: "<<=","leftshifteq";
843: ">>=","rightshifteq";
844:
845: "++","incr";
846: "--","decr";
847: "[]","subscript";
848: ]
849: ;;
850: let operators = Hashtbl.create 97
851: ;;
852: List.iter
853: (fun (k,v)-> Hashtbl.add operators ("operator"^k) v)
854: oplist
855: ;;
856:
857: let fixsym k =
858: try (* hackery .. won't work with qualified names *)
859: Hashtbl.find operators k
860: with Not_found ->
861: let k = String.copy k in
862: srepl k ':' '_';
863: k
864:
865: let rpl {file=s} which =
866: let stab = getstab s in
867: match which with
868: | `aliases (k,v) ->
869: let k = fixsym k in
870: Hashtbl.replace stab.aliases k v;
871: Hashtbl.replace control.all_types k s
872:
873: | `struct_aliases(k,v) ->
874: let k = fixsym k in
875: Hashtbl.replace stab.struct_aliases k v;
876: Hashtbl.replace control.all_types k s
877:
878: | `abstract_types (k,v) ->
879: let k = fixsym k in
880: Hashtbl.replace stab.abstract_types k v;
881: Hashtbl.replace control.all_types k s
882:
883: | `incomplete_types (k,v) ->
884: let k = fixsym k in
885: Hashtbl.replace stab.incomplete_types k v
886:
887: | `variables(k,v) ->
888: let k = fixsym k in
889: Hashtbl.replace stab.variables k v
890:
891: | `functions((k,ts,cv),v) ->
892: let k = fixsym k in
893: Hashtbl.replace stab.functions (k,ts,cv) v
894:
895: | `fields(k,v) ->
896: let k = fixsym k in
897: Hashtbl.replace stab.fields k v
898:
899: | `cstruct (k,v) ->
900: let k = fixsym k in
901: Hashtbl.replace control.all_types k k;
902: Hashtbl.replace stab.cstructs k v
903:
904: | `procedures((k,ts,cv),v) ->
905: let k = fixsym k in
906: Hashtbl.replace stab.procedures (k,ts,cv) v
907:
908: | `enums(k,v) ->
909: let k = fixsym k in
910: Hashtbl.replace stab.enums k v
911:
912: | `callback_type (s,(t,i)) ->
913: Hashtbl.replace stab.callback_types s (t,i)
914:
915: | `callback_client (s,(t,cbt,i,j)) ->
916: Hashtbl.replace stab.callback_clients s (t,cbt,i,j)
917:
918: ;;
919:
920: let add_file fname =
921: control.files <- StringSet.add fname control.files
922: ;;
923:
924: let add_loc {file=fname} =
925: add_file fname
926: ;;
927:
928: (* find all the void* in an argument list *)
929: let find_voidps ps =
930: let voids = ref [] in
931: let i = ref 0 in
932: List.iter
933: (fun (_,t,_) ->
934: (match unrollType t with
935: | TPtr (TVoid _,[]) -> voids := !i :: !voids
936: | _ -> ()
937: );
938: incr i
939: )
940: ps
941: ;
942: !voids
943:
944: (* check if a function pointer is a callback, by
945: seeing if it contains exactly one void * argument
946: *)
947: let is_callbackp t =
948: match t with
949: | TPtr (TFun (_,Some ps,false,_),_) ->
950: List.length (find_voidps ps) = 1
951: | _ -> false
952:
953: (* Find all the arguments which are callbacks *)
954: let find_callbackps ps =
955: let callbacks = ref [] in
956: let i = ref 0 in
957: List.iter
958: (fun (_,t,_) ->
959: if is_callbackp t
960: then callbacks := !i :: !callbacks
961: ;
962: incr i
963: )
964: ps
965: ;
966: !callbacks
967:
968: (* get the indices in an argument list of the callback
969: and client data pointer, and the index of the client
970: data pointer in the callback type as well, return None
971: if they can't be uniquely identified
972: *)
973:
974: let get_callback_data ps =
975: let callbacks = find_callbackps ps in
976: let voids = find_voidps ps in
977: match callbacks, voids with
978: | [cbc_i], [cbc_adri] ->
979: begin match List.nth ps cbc_i with
980: | _,TPtr (TFun (_,Some ps,false,_),_),_ ->
981: begin match find_voidps ps with
982: | [cbi] -> Some (cbc_i,cbc_adri,cbi)
983: | _ -> assert false
984: end
985: | _ -> assert false
986: end
987: | _ -> None
988:
989: let check_callback t = match t with
990: | TFun (_,Some ps,false,_) ->
991: begin match get_callback_data ps with
992: | Some (cbc_i, cbc_adri,cbi) ->
993: let _,cbt,_ = List.nth ps cbc_i in
994: Some (cbc_i, cbc_adri,cbi, cbt)
995: | None -> None
996: end
997: | TFun _ -> None
998: | _ -> failwith "Check for callbacks in non-function"
999:
1000: let handle_callback_maybe ft registry key key' fname loc =
1001: match check_callback ft with
1002: | None -> ()
1003: | Some (cbc_i, cbc_adri, cbi, cbt) ->
1004: (*
1005: print_endline
1006: (
1007: "Found callback client " ^ fname ^
1008: "\n callback index = " ^ string_of_int cbc_i ^
1009: "\n client data index = " ^ string_of_int cbc_adri ^
1010: "\n callback type = " ^ sot registry cbt ^
1011: "\n callback type client data index = " ^ string_of_int cbi
1012: )
1013: ;
1014: *)
1015: let s = sot registry cbt in
1016: rpl loc (`callback_type (s,(cbt,cbi)));
1017: rpl loc (`callback_client (fname,(ft,s,cbc_i,cbc_adri)))
1018:
1019: let ptr key a =
1020: cvqual a ^ "ptr[" ^ key ^ "]"
1021:
1022: let handle_global_fun ft registry key key' fname loc =
1023: handle_callback_maybe ft registry key key' fname loc;
1024: match ft with
1025: | TFun (TVoid _,Some ps,false,a) ->
1026: let tsig = map (fun (_,t,a) -> typeSig t) ps in
1027: let args =
1028: if length ps = 0 then "1"
1029: else String.concat " * " (List.map (soa registry) ps)
1030: in
1031: let cv = cvqual a in
1032: let ct = if key = key' then "" else key'^"($a);" in
1033: rpl loc (`procedures ((key,tsig,cv), (args,ct)))
1034:
1035: | TFun (TVoid _,None,false,a) ->
1036: let args = "1" in
1037: let cv = cvqual a in
1038: rpl loc (`procedures ((key,[],cv), (args,key'^"();")))
1039:
1040: | TFun (TVoid _,Some _,true,a) ->
1041: let cv = cvqual a in
1042: let ct = if key = key' then "" else key'^"($a);" in
1043: rpl loc (`procedures ((key^"[t]",[],cv), ("t",ct)))
1044:
1045: | TFun (ret,Some ps,false,a) ->
1046: let ftb =
1047: let ret = sot (getreg loc) ret
1048: and args = List.map (soa registry) ps
1049: and ct = if key = key' then "" else key'^"($a)"
1050: in
1051: (
1052: (
1053: if length ps = 0
1054: then "1"
1055: else String.concat " * " args
1056: )
1057: ^
1058: " -> " ^ ret,ct
1059: )
1060: in
1061: let tsig = map (fun (_,t,a) -> typeSig t) ps in
1062: let cv = cvqual a in
1063: rpl loc (`functions ((key,tsig,cv), ftb))
1064:
1065: | TFun (ret,None,false,a) ->
1066: let ret = sot (getreg loc) ret in
1067: let ftb = "1 -> " ^ ret,key'^"()" in
1068: let cv = cvqual a in
1069: rpl loc (`functions ((key,[],cv), ftb))
1070:
1071: | TFun (ret,Some _,true,a) ->
1072: let ftb =
1073: let ret = sot (getreg loc) ret in
1074: "t -> " ^ ret,key'^"($a)"
1075: in
1076: let cv = cvqual a in
1077: rpl loc (`functions ((key^"[t]",[],cv), ftb))
1078:
1079: | _ -> assert false
1080:
1081: let handle_method ft registry key fname loc =
1082: match ft with
1083: (* procedures *)
1084: | (TVoid _,Some ps,false,a) ->
1085: let key = ptr (fixsym key) a in
1086: let args =
1087: if length ps = 0 then key
1088: else String.concat " * " (key :: (List.map (soa registry) ps))
1089: in
1090: let tsig = map (fun (_,t,a) -> typeSig t) ps in
1091: let cv = cvqual a in
1092: rpl loc (`procedures ((fname,tsig,cv), (args,"$1->"^fname^"($b);")))
1093:
1094: (* no type arg = void *)
1095: | (TVoid _,None,false,a) ->
1096: let key = ptr key a in
1097: let args = key in
1098: let cv = cvqual a in
1099: rpl loc (`procedures ((fname,[],cv), (args,"$1->"^fname^"();")))
1100:
1101: (* variadic *)
1102: | (TVoid _,Some t,true,a) ->
1103: let key = ptr key a in
1104: let cv = cvqual a in
1105: rpl loc (`procedures ((fname^"[t]",[],cv), ("t","$1->"^fname^"($b);")))
1106:
1107: (* functions *)
1108: | (ret,Some ps,false,a) ->
1109: let key = ptr key a in
1110: let ftb =
1111: let ret = sot (getreg loc) ret
1112: and args = List.map (soa registry) ps
1113: in
1114: (
1115: (
1116: if length ps = 0
1117: then key
1118: else String.concat " * " (key :: args)
1119: )
1120: ^
1121: " -> " ^ ret,"$1->"^fname^"($a)"
1122: )
1123: in
1124: let tsig = map (fun (_,t,a) -> typeSig t) ps in
1125: let cv = cvqual a in
1126: rpl loc (`functions ((fname,tsig,cv), ftb))
1127:
1128: (* no type arg = void *)
1129: | (ret,None,false,a) ->
1130: let key = ptr key a in
1131: let ret = sot (getreg loc) ret in
1132: let ftb = key ^ " -> " ^ ret,"$1->"^fname^"()" in
1133: let cv = cvqual a in
1134: rpl loc (`functions ((fname,[],cv), ftb))
1135:
1136: (* variadic *)
1137: | (ret,Some _,true,a) ->
1138: let key = ptr key a in
1139: let ftb =
1140: let ret = sot (getreg loc) ret in
1141: "t -> " ^ ret,"$1->"^fname^"($b)"
1142: in
1143: let cv = cvqual a in
1144: rpl loc (`functions ((fname^"[t]",[],cv), ftb))
1145:
1146: (* can't be both variadic and have no arguments *)
1147: | (_,None,true,_) -> assert false
1148:
1149: let handle_field registry key fname ftype loc =
1150: match ftype with
1151: | TFun (a,b,c,d) -> handle_method (a,b,c,d) registry key fname loc
1152:
1153: | _ ->
1154: let t = key ^ " -> " ^ sot registry ftype in
1155: rpl loc (`fields (("get_"^fname), (t,"$1->"^fname)))
1156:
1157: let gen_cstruct registry loc key cname cfields =
1158: let flds = ref [] in
1159: iter
1160: (fun {fname=fname; ftype=ftype} ->
1161: let t = sot registry ftype in
1162: flds := (rplname fname,t) :: !flds
1163: )
1164: cfields
1165: ;
1166: let flds = rev !flds in
1167: rpl loc (`cstruct (cname, flds));
1168: if key <> cname then
1169: rpl loc (`aliases (key, cname))
1170:
1171: let handle_global g = let loc = get_globalLoc g in
1172: add_loc loc;
1173: let type_name = flx_tname g in
1174: match isanon g,flx_name g,flx_name' g with
1175: | _,None,_
1176: | true,_,_ ->
1177: begin match g with
1178:
1179: (* enum { .. }; *)
1180: | GEnumTag (ei,_) ->
1181: begin match ei with { eitems=eitems } ->
1182: iter
1183: (fun (s,_,_) ->
1184: if ispublic s then rpl loc (`enums (rplname s,s))
1185: )
1186: eitems
1187: end
1188: | _ -> ()
1189: end
1190:
1191: | _,Some _,None -> assert false
1192: | false,Some key,Some key' ->
1193: if not (Hashtbl.mem control.rejects key) then
1194: match g with
1195: | GType (ti,loc) ->
1196: let registry = getreg loc in
1197: begin
1198: match ti with {ttype=ttype} ->
1199: match ttype with
1200: | TComp (ci,_) ->
1201: let anon= achk (ciname ci) in
1202: (*
1203: begin match ci with { cname=cname; cfields=cfields } ->
1204: iter
1205: (fun {fname=fname; ftype=ftype} ->
1206: if not (isanont ftype) && ispublic fname then
1207: handle_field registry key fname ftype loc
1208: )
1209: cfields
1210: end
1211: ;
1212: *)
1213: if anon then
1214: rpl loc (`abstract_types (type_name, key'))
1215: else
1216: let v = ptdef registry ti in
1217: rpl loc (`struct_aliases (type_name, v))
1218:
1219: | TEnum (ei,_) ->
1220: begin match ei with { eitems=eitems } ->
1221: iter
1222: (fun (s,_,_) -> if ispublic s then rpl loc (`enums (rplname s,s)))
1223: eitems
1224: end
1225: ;
1226: if achk (einame ei) then
1227: rpl loc (`abstract_types (type_name, key'))
1228: else
1229: rpl loc (`aliases (type_name, (ptdef registry ti)))
1230:
1231: | TFun (_,_,true,_) ->
1232: (* HACK: varargs function typedef *)
1233: rpl loc (`abstract_types (type_name, key'))
1234:
1235: | t ->
1236: if isanont t then
1237: rpl loc (`abstract_types (type_name, key'))
1238: else
1239: let v = ptdef registry ti in
1240: rpl loc (`aliases (type_name, v))
1241: end
1242:
1243: | GCompTag (ci,loc) ->
1244: let registry = getreg loc in
1245: begin match ci with {
1246: cname=cname;
1247: cfields=cfields;
1248: cstruct=cstruct
1249: } ->
1250: if can_gen_ctype cstruct cfields then
1251: gen_cstruct registry loc type_name cname cfields
1252: else begin
1253: rpl loc (`abstract_types (type_name, (pcci ci)));
1254: iter
1255: (fun {fname=fname; ftype=ftype} ->
1256: if not (isanont ftype) && ispublic fname then
1257: handle_field registry type_name fname ftype loc
1258: )
1259: cfields
1260: end
1261: end
1262:
1263:
1264: | GCompTagDecl (ci,loc) ->
1265: rpl loc (`incomplete_types (type_name, (pcci ci)))
1266:
1267: | GEnumTag (ei,loc) ->
1268: rpl loc (`aliases (type_name, "int"));
1269: begin match ei with { eitems=eitems } ->
1270: iter
1271: (fun (s,_,_) -> if ispublic s then rpl loc (`enums (rplname s,s)))
1272: eitems
1273: end
1274:
1275: | GEnumTagDecl (ci,loc) -> rpl loc (`aliases (type_name, "int"))
1276:
1277: | GVar (vi,_,loc)
1278: | GFun ({svar=vi},loc)
1279: | GVarDecl (vi,loc) ->
1280: let registry = getreg loc in
1281: let vname, vtype=
1282: match vi with {vname=vname; vtype=vtype}->vname,vtype
1283: in
1284: if ispublic vname then
1285: begin match vtype with
1286: | TFun _ -> handle_global_fun vtype registry key key' vname loc
1287: | _ ->
1288: rpl loc (`variables (key, (sot (getreg loc) vtype)))
1289: end
1290:
1291: | GAsm _ -> print_endline "GASM"
1292: | GPragma _ -> print_endline "PRAGMA"
1293: | GText _ -> print_endline "TEXT"
1294: ;;
1295:
1296: List.iter handle_global gs
1297: ;;
1298:
1299: let is_nonempty h =
1300: try
1301: Hashtbl.iter (fun _ -> raise Not_found) h;
1302: false
1303: with Not_found -> true
1304: ;;
1305:
1306: exception Found of string
1307:
1308: let pathname_of f =
1309: try
1310: iter
1311: (fun s ->
1312: let x = Filename.concat s f in
1313: if Sys.file_exists x then raise (Found x)
1314: )
1315: control.include_path;
1316: raise Not_found
1317: with Found s -> s
1318: ;;
1319:
1320: let rec find_includes' includes fname =
1321: if not (StringSet.mem fname !includes) then
1322: let f = force_open_in "find_includes'" fname in
1323: includes := StringSet.add fname !includes;
1324: begin try
1325: let rec aux () =
1326: let line = input_line f in
1327: let n = String.length line in
1328: let i = ref 0 in
1329:
1330: try
1331: (* skip white *)
1332: while !i < n && line.[!i]=' ' do incr i done;
1333: if !i = n then raise Next;
1334:
1335: (* check # *)
1336: if line.[!i]<>'#' then raise Next;
1337: incr i;
1338:
1339: (* skip white *)
1340: while !i < n && line.[!i]=' ' do incr i done;
1341: if !i = n then raise Next;
1342:
1343: (* check include *)
1344: if !i+String.length "include" > n then raise Next;
1345: let li = String.length "include" in
1346: if (String.sub line !i li) <> "include" then raise Next;
1347: i := !i + li;
1348:
1349: (* skip white *)
1350: while !i < n && line.[!i]=' ' do incr i done;
1351:
1352: (* check < or '"' *)
1353: if line.[!i]<>'"' && line.[!i]<>'<' then raise Next;
1354: incr i;
1355:
1356: (* skip to > or '"' *)
1357: let j = !i in
1358: while !i < n && line.[!i]<>'>' && line.[!i]<>'"' do incr i done;
1359:
1360: (* extract filename *)
1361: let filename = String.sub line j (!i-j) in
1362:
1363:
1364: (* lookup full path name *)
1365: let filename =
1366: if not (Filename.is_relative filename) then filename else
1367: try pathname_of filename
1368: with Not_found ->
1369: (*
1370: print_endline
1371: (
1372: "[include_file'] Can't resolve " ^ filename ^
1373: " included from " ^ fname
1374: );
1375: *)
1376: raise Next
1377: in
1378: add_file filename;
1379:
1380: (* if not already known, put transitive closure in set *)
1381: if StringSet.mem filename !includes then raise Next;
1382: includes := StringSet.add filename !includes;
1383: find_includes' includes filename;
1384:
1385: (* next line *)
1386: raise Next
1387: with Next -> aux ()
1388: in
1389: aux()
1390: with End_of_file -> close_in f
1391: end
1392: ;;
1393:
1394: let find_includes fname =
1395: let includes = ref StringSet.empty in
1396: find_includes' includes fname;
1397: let extras =
1398: try Hashtbl.find control.rev_merge_files fname
1399: with Not_found -> []
1400: in
1401: iter (find_includes' includes) extras
1402: ;
1403: stringset_map map_filename !includes
1404: ;;
1405:
1406: let global_includes = ref StringSet.empty
1407: ;;
1408:
1409: Hashtbl.iter
1410: begin
1411: fun fname stab ->
1412: let includes = ref (find_includes stab.stab_cfile) in
1413: let ict = Hashtbl.create 97 in
1414: let xtyps = Hashtbl.create 97 in
1415: Hashtbl.iter
1416: (fun k v ->
1417: if not (Hashtbl.mem stab.abstract_types k) then
1418: try
1419: let file = Hashtbl.find control.all_types k in
1420: includes := StringSet.add file !includes;
1421: Hashtbl.add xtyps k file;
1422:
1423: with Not_found ->
1424: Hashtbl.add ict k v;
1425: let v',ms =
1426: try Hashtbl.find control.incomplete_types_cache k
1427: with Not_found -> v,[]
1428: in
1429: if v'<>v then
1430: failwith ("Inconsistent type " ^k^"->"^ v ^ " <> " ^ v')
1431: ;
1432: Hashtbl.replace control.incomplete_types_cache k (v,stab.stab_module::ms)
1433: else
1434: ()
1435: )
1436: stab.incomplete_types
1437: ;
1438:
1439: let udt = Hashtbl.create 97 in
1440: Hashtbl.iter
1441: (fun k v ->
1442: let k = rplname k in
1443: if not (Hashtbl.mem control.rejects k) then
1444: try
1445: let file = Hashtbl.find control.all_types k in
1446: includes := StringSet.add file !includes;
1447: with Not_found ->
1448: if not (Hashtbl.mem control.incomplete_types_cache k) then
1449: Hashtbl.add udt k v
1450: )
1451: stab.used_types
1452: ;
1453: stab.includes <- !includes;
1454: global_includes := StringSet.union !global_includes !includes;
1455: stab.udt <- udt;
1456: stab.ict <- ict;
1457: stab.xtyps <- xtyps
1458: end
1459: control.stabs
1460: ;;
1461:
1462: (* closure for stabs .. *)
1463: StringSet.iter
1464: (fun s -> ignore(getstab s))
1465: !global_includes
1466: ;;
1467:
1468: StringSet.iter
1469: (fun s ->
1470: let filename =
1471: if not (Filename.is_relative s) then s else
1472: try pathname_of s
1473: with Not_found ->
1474: print_endline ( "Can't resolve primary file " ^ s);
1475: print_endline ("in path: ");
1476: iter
1477: (fun s -> print_endline s)
1478: control.include_path
1479: ;
1480: print_endline "Try adding path statement to control file";
1481: failwith ("Filename resolution error")
1482: in
1483: ignore(getstab filename)
1484: )
1485: control.raw_includes
1486: ;;
1487:
1488: let rec find_macros fname =
1489: let macros = ref [] in
1490: begin
1491: try
1492: let f = open_in fname in
1493: begin
1494: try
1495: let rec aux () =
1496: let line = input_line f in
1497: let n = String.length line in
1498: let i = ref 0 in
1499:
1500: try
1501: (* skip white *)
1502: while !i < n && line.[!i]=' ' do incr i done;
1503: if !i = n then raise Next;
1504:
1505: (* check # *)
1506: if line.[!i]<>'#' then raise Next;
1507: incr i;
1508:
1509: (* skip white *)
1510: while !i < n && line.[!i]=' ' do incr i done;
1511: if !i = n then raise Next;
1512:
1513: (* check include *)
1514: let li = String.length "define" in
1515: if !i+li > n then raise Next;
1516: if (String.sub line !i li) <> "define" then raise Next;
1517: i := !i + li;
1518:
1519: (* skip white *)
1520: while !i < n && line.[!i]=' ' do incr i done;
1521: let m = String.sub line !i (n - !i) in
1522: macros := m :: !macros;
1523:
1524: (* next line *)
1525: raise Next
1526: with Next -> aux ()
1527: in
1528: aux()
1529: with End_of_file -> close_in f
1530: end
1531: with _ -> ()
1532: end
1533: ;
1534: !macros
1535: ;;
1536: exception Equal
1537: exception Not_equal
1538: ;;
1539: let fnames = ref [];;
1540: Hashtbl.iter
1541: (fun f _ -> fnames := f :: !fnames)
1542: control.stabs
1543: ;;
1544: let fnames = List.sort compare !fnames
1545: ;;
1546: iter begin
1547: fun fname ->
1548: let stab = Hashtbl.find control.stabs fname in
1549: let outname = stab.stab_flxfile in
1550: let mode, outf =
1551: if Sys.file_exists outname then
1552: `tmp, force_open_out "generate_file" "tmp.tmp"
1553: else
1554: `orig,autocreate outname
1555: in
1556: let pe s = output_string outf (s ^ "\n") in
1557:
1558: pe ("//Module : " ^ stab.stab_module);
1559: pe ("//Timestamp : " ^ compile_start_gm_string);
1560: pe ("//Timestamp : " ^ compile_start_local_string);
1561: pe ("//Raw Header : " ^ fname);
1562: pe ("//Preprocessor : " ^ control.preprocessor);
1563: pe ("//Input file: " ^ control.preout_filename);
1564: pe ("//Flxcc Control : " ^ control.control_filename);
1565: pe ("//Felix Version : " ^ !version_data.version_string);
1566: pe ("include 'std';");
1567: pe "";
1568: let macros = find_macros fname in
1569: iter
1570: (fun s-> pe ("//#define " ^ s))
1571: macros
1572: ;
1573: if not (mem fname control.noincludes) then
1574: pe ("header '#include \"" ^ fname^"\"';")
1575: else
1576: pe ("//NOT INCLUDED: \"" ^ fname^"\"")
1577: ;
1578:
1579:
1580: begin
1581: try
1582: Hashtbl.iter
1583: (fun k v->
1584: match Hashtbl.find control.incomplete_types_cache k with
1585: | (_,[_]) -> ()
1586: | _ ->
1587: pe ("include \"_incomplete_types_cache\";");
1588: raise Not_found
1589: )
1590: stab.ict
1591: with Not_found -> ()
1592: end
1593: ;
1594:
1595:
1596: let include_depends =
1597: let x = stringset_map map_filename stab.includes in
1598: let x = stringset_map flxinclude_of_cfile x in
1599: StringSet.remove stab.stab_flxinclude x
1600: in
1601: let module_depends =
1602: let x = stringset_map map_filename stab.includes in
1603: let x = stringset_map (fun s -> module_of_cfilename s) x in
1604: StringSet.remove stab.stab_module x
1605: in
1606:
1607: if StringSet.cardinal include_depends > 0 then
1608: begin
1609: pe "";
1610: pe "//INCLUDES";
1611: StringSet.iter
1612: (fun incname ->
1613: pe ("include \"" ^ incname^ "\";")
1614: )
1615: include_depends
1616: end
1617: ;
1618:
1619: pe "";
1620: pe ("module " ^ stab.stab_module ^ "\n{");
1621: begin
1622: let pe s = output_string outf (" " ^ s ^ "\n") in
1623: pe "open C_hack;";
1624: if StringSet.cardinal module_depends > 0 then
1625: begin
1626: StringSet.iter
1627: (fun modulename' ->
1628: pe ("open " ^ modulename' ^";")
1629: )
1630: module_depends
1631: end
1632: ;
1633:
1634: if is_nonempty stab.abstract_types then
1635: begin
1636: pe "";
1637: pe "//ABSTRACT TYPES";
1638: Hashtbl.iter
1639: (fun k v->
1640: pe ("type " ^ k ^ " = '" ^ v ^ "';")
1641: )
1642: stab.abstract_types
1643: end
1644: ;
1645:
1646: if is_nonempty stab.cstructs then
1647: begin
1648: pe "";
1649: pe "//CSTRUCTS ";
1650: Hashtbl.iter
1651: (fun k flds ->
1652: pe ("cstruct " ^ k ^ " {");
1653: iter (fun (fld,typ) ->
1654: pe (" " ^ fld ^": " ^ typ^ ";")
1655: )
1656: flds
1657: ;
1658: pe ("}")
1659: )
1660: stab.cstructs
1661: end
1662: ;
1663:
1664: if is_nonempty stab.registry then
1665: begin
1666: pe "";
1667: pe "//C FUNCTION POINTER TYPES";
1668: Hashtbl.iter
1669: (fun _ (name,tdef)->
1670: pe ("header '''" ^ tdef ^ "''';");
1671: pe ("type " ^ name ^ " = '" ^ name ^ "';")
1672: )
1673: stab.registry
1674: end
1675: ;
1676:
1677: if is_nonempty stab.xtyps then
1678: begin
1679: pe "";
1680: pe "//EXTERNALLY COMPLETED TYPES";
1681: Hashtbl.iter
1682: (fun k v->
1683: let m = module_of_cfilename v in
1684: pe ("//type " ^ k ^ " defined in "^m^"='" ^ v ^ "';")
1685: )
1686: stab.xtyps
1687: end
1688: ;
1689:
1690: if is_nonempty stab.ict then
1691: begin
1692: pe "";
1693: pe "//PURE INCOMPLETE TYPES";
1694: Hashtbl.iter
1695: (fun k v->
1696: match Hashtbl.find control.incomplete_types_cache k with
1697: | (_,[_]) ->
1698: pe ("type " ^ k ^ " = '" ^ v ^ "'; //local")
1699: | (_,ls) ->
1700: pe ("typedef " ^ k ^ " = _incomplete_types::" ^ k ^ ";//shared");
1701: iter (fun s->pe ("//shared by: " ^ s)) ls
1702: )
1703: stab.ict
1704: end
1705: ;
1706:
1707: if is_nonempty stab.udt then
1708: begin
1709: pe "";
1710: pe "//TYPES WE CAN'T FIND";
1711: Hashtbl.iter
1712: (fun k _ ->
1713: pe ("//type " ^ k ^ " ??")
1714: )
1715: stab.udt
1716: end
1717: ;
1718:
1719: if is_nonempty stab.struct_aliases then
1720: begin
1721: pe "";
1722: pe "//STRUCT or UNION TAG ALIASES";
1723: Hashtbl.iter
1724: (fun k v->
1725: (* va_list is already defined in the standard library *)
1726: if k <> "va_list" then
1727: (* hack to fiddle typedef X {} X *)
1728: if not (Hashtbl.mem stab.cstructs k) then
1729: pe ("typedef " ^ k ^ " = " ^ v ^ ";")
1730: )
1731: stab.struct_aliases
1732: end
1733: ;
1734:
1735: if is_nonempty stab.aliases then
1736: begin
1737: pe "";
1738: pe "//TYPE ALIASES";
1739: Hashtbl.iter
1740: (fun k v->
1741: (* va_list is already defined in the standard library *)
1742: if k <> "va_list" then
1743: pe ("typedef " ^ k ^ " = " ^ v ^ ";")
1744: )
1745: stab.aliases
1746: end
1747: ;
1748:
1749: if is_nonempty stab.variables then
1750: begin
1751: pe "";
1752: pe "//VARIABLES";
1753: Hashtbl.iter
1754: (fun k v->
1755: pe ("const " ^ k ^ ": " ^v^ " = '" ^ k ^ "';")
1756: )
1757: stab.variables
1758: end
1759: ;
1760:
1761: if is_nonempty stab.enums then
1762: begin
1763: pe "";
1764: pe "//ENUMERATION CONSTANTS";
1765: Hashtbl.iter
1766: (fun k v ->
1767: pe ("const " ^ k ^ ": int = '" ^ v ^ "';")
1768: )
1769: stab.enums
1770: end
1771: ;
1772:
1773: if is_nonempty stab.procedures then
1774: begin
1775: pe "";
1776: pe "//PROCEDURES";
1777: let ps = ref [] in
1778: Hashtbl.iter
1779: (fun (k,_,_) v -> ps := (k,v):: !ps)
1780: stab.procedures
1781: ;
1782: let ps = sort compare !ps in
1783: iter
1784: (fun (k, (v,b)) ->
1785: if b = "" then
1786: pe ("proc " ^ k ^ ": " ^v^ ";")
1787: else
1788: pe ("proc " ^ k ^ ": " ^v^ " = '"^b^"';")
1789: )
1790: ps
1791: end
1792: ;
1793:
1794: if is_nonempty stab.functions then
1795: begin
1796: pe "";
1797: pe "//FUNCTIONS";
1798: let ps = ref [] in
1799: Hashtbl.iter
1800: (fun (k,_,_) v -> ps := (k,v):: !ps)
1801: stab.functions
1802: ;
1803: let ps = sort compare !ps in
1804: iter
1805: (fun (k, (v,b))->
1806: if b = "" then
1807: pe ("fun " ^ k ^ ": " ^v^ ";")
1808: else
1809: pe ("fun " ^ k ^ ": " ^v^ " = '" ^ b ^ "';")
1810: )
1811: ps
1812: end
1813: ;
1814:
1815: if is_nonempty stab.callback_types then
1816: begin
1817: let sot t = sot stab t in
1818: let soa a = soa stab a in
1819: pe "";
1820: pe "//CALLBACK TYPE WRAPPERS";
1821: Hashtbl.iter
1822: (fun tname (t, cbi)->
1823: pe ("//callback type " ^ tname ^ ", client data at " ^ string_of_int cbi);
1824: let ccbt = "_ccbt_" ^ tname in
1825: let fcbt = "_fcbt_" ^ tname in
1826: let fcbat = "_fcbat_" ^ tname in
1827: let fcbw = "_fcbw_" ^ tname in
1828: match t with
1829: | TPtr (TFun (ret,Some ps, false,a),_) ->
1830: (* fix arg names *)
1831: let i = ref 0 in
1832: let ps =
1833: map
1834: (fun (_,t,a) ->
1835: incr i;
1836: let pn = "a"^ string_of_int !i in
1837: pn,t,a
1838: )
1839: ps
1840: in
1841: let t' = TFun (ret,Some ps, false,a) in
1842: (* get the non-client data arguments *)
1843: let ps' = ref [] in
1844: let i = ref 0 in
1845: iter
1846: (fun x -> if cbi = !i then () else ps' := x :: !ps'; incr i)
1847: ps
1848: ;
1849: let ps' = rev !ps' in
1850: (* make a typedef for the felix callback type
1851: mainly as documentation [since the client will
1852: declare a function of this type, the actual
1853: typedef isn't that useful]
1854: *)
1855:
1856: begin match ret with
1857: | TVoid _ ->
1858: let args =
1859: if length ps' = 0 then "1"
1860: else String.concat " * " (List.map soa ps')
1861: in
1862: pe ("typedef " ^ fcbat ^ " = " ^ args ^ "; ");
1863: pe ("export type (" ^ fcbat ^ ") as \""^fcbat^"\";");
1864: pe ("typedef " ^ fcbt ^ " = " ^ args ^ " -> void; ");
1865: pe ("export type (" ^ fcbt ^ ") as \""^fcbt^"\";");
1866: let sr = {line=0;file="";byte=0} in
1867: let vi =
1868: {
1869: vname=fcbw; vtype=t'; vattr=[]; vglob=true;
1870: vinline=false; vdecl=sr; vid=0; vaddrof=false;
1871: vreferenced=true; vstorage=NoStorage
1872: }
1873: in
1874: let g = GVarDecl (vi,sr) in
1875: let d = defaultCilPrinter#pGlobal () g in
1876: let s = Flx_cil_pretty.sprint 65 d in
1877: let s = reformatc s in
1878: pe ("header '''" ^ s ^ "''';\n");
1879: pe ("const "^fcbw^": " ^ tname ^ " = \"" ^ fcbw ^ "\";");
1880:
1881: (* hack: elide trailing semicolon *)
1882: let s = String.sub s 0 (String.length s - 1) in
1883: pe ("body '''\n " ^ s ^ "{");
1884: let oargs = ref [] in
1885: iter
1886: (fun i -> if i <> cbi then
1887: oargs := ("a" ^ string_of_int (i+1)) :: !oargs
1888: )
1889: (nlist (length ps))
1890: ;
1891: pe (
1892: " con_t *p = (("^fcbt^")a" ^ string_of_int (cbi+1) ^
1893: ")->call(" ^
1894: if List.length !oargs > 1 then
1895: "0, " ^fcbat^"(" ^ String.concat ", " (rev !oargs)^"));"
1896: else
1897: String.concat ", " ("0" :: rev !oargs)^");"
1898: );
1899: pe (" while(p) p=p->resume();");
1900: pe ("}''';\n");
1901:
1902: | _ ->
1903: let args =
1904: if length ps' = 0 then "1"
1905: else String.concat " * " (List.map soa ps')
1906: in
1907: let args =
1908: if length ps' = 0 then "1"
1909: else String.concat " * " (List.map soa ps')
1910: in
1911: pe ("typedef " ^ fcbat ^ " = "^ args ^ ";");
1912: pe ("export type (" ^ fcbat ^ ") as \""^fcbat^"\";");
1913: pe ("typedef " ^ fcbt ^ " = "^ args ^ " -> "^sot ret^"; ");
1914: pe ("export type (" ^ fcbt ^ ") as \""^fcbt^"\";");
1915: let sr = {line=0;file="";byte=0} in
1916: let vi =
1917: {
1918: vname=fcbw; vtype=t'; vattr=[]; vglob=true;
1919: vinline=false; vdecl=sr; vid=0; vaddrof=false;
1920: vreferenced=true; vstorage=NoStorage
1921: }
1922: in
1923: let g = GVarDecl (vi,sr) in
1924: let d = defaultCilPrinter#pGlobal () g in
1925: let s = Flx_cil_pretty.sprint 65 d in
1926: let s = reformatc s in
1927: pe ("header '''" ^ s ^ "''';\n");
1928: pe ("const "^fcbw^": " ^ tname ^ " = \"" ^ fcbw ^ "\";");
1929:
1930: (* hack: elide trailing semicolon *)
1931: let s = String.sub s 0 (String.length s - 1) in
1932: pe ("body '''\n " ^ s ^ "{");
1933: let oargs = ref [] in
1934: iter
1935: (fun i -> if i <> cbi then
1936: oargs := ("a" ^ string_of_int (i+1)) :: !oargs
1937: )
1938: (nlist (length ps))
1939: ;
1940: pe (
1941: " return (("^fcbt^")a" ^ string_of_int (cbi+1) ^
1942: ")->apply(" ^
1943: if List.length !oargs > 1 then
1944: fcbat^"(" ^
1945: String.concat ", " (rev !oargs)^"));"
1946: else
1947: String.concat ", " (rev !oargs)^");"
1948: );
1949: pe ("}''';\n");
1950:
1951: end
1952: ;
1953: | _ -> assert false
1954: )
1955: stab.callback_types
1956: end
1957: ;
1958:
1959: if is_nonempty stab.callback_clients then
1960: begin
1961: let sot t = sot stab t in
1962: let soa a = soa stab a in
1963: pe "";
1964: pe "//CALLBACK CLIENT WRAPPERS";
1965: Hashtbl.iter
1966: (fun fname (t, cbt, cbi,adri)->
1967: pe ("//callback client " ^ fname ^ ", client data at " ^ string_of_int cbi ^ ", callback at " ^ string_of_int adri);
1968: match t with
1969: | TFun (ret,Some ps, false,a) ->
1970: (* fix arg names *)
1971: let i = ref 0 in
1972: let args = ref [] in
1973: iter
1974: (fun (_,t,a) ->
1975: if !i <> adri then begin
1976: let pn = "a"^ string_of_int (!i+1) in
1977: let t =
1978: if !i = cbi then "_fcbt_" ^ sot t
1979: else sot t
1980: in
1981: args := (pn,t) :: !args
1982: end
1983: ;
1984: incr i
1985: )
1986: ps
1987: ;
1988: let args = rev !args in
1989: let params =
1990: catmap ", "
1991: (fun (n,t) -> n ^ ": " ^ t)
1992: args
1993: in
1994: let call_args = ref [] in
1995: let i = ref 0 in
1996: for j = 0 to length ps - 1 do
1997: call_args :=
1998: begin
1999: if j = adri then
2000: ("C_hack::cast[address]a"^ string_of_int (cbi+1))
2001: else if j = cbi then
2002: ("_fcbw_" ^ cbt)
2003: else begin
2004: while !i=cbi || !i=adri do incr i done;
2005: let a = "a"^ string_of_int (!i+1) in
2006: incr i;
2007: a
2008: end
2009: end
2010: ::
2011: !call_args
2012: done
2013: ;
2014: begin match ret with
2015: | TVoid _ ->
2016: pe ("proc wrapper_" ^ fname ^ "(" ^ params ^ ") {");
2017: pe (" " ^fname^"(" ^ String.concat ", " (rev !call_args) ^ ");");
2018: pe ("}")
2019:
2020: | ret ->
2021: let ret = sot ret in
2022: pe ("fun wrapper_" ^ fname ^ "(" ^ params ^ "): "^ret^"= {");
2023: pe (" return " ^fname^"(" ^ String.concat ", " (rev !call_args) ^ ");");
2024: pe ("}")
2025:
2026: end
2027:
2028: | _ -> assert false
2029: )
2030: stab.callback_clients
2031: end
2032: ;
2033:
2034: if is_nonempty stab.fields then
2035: begin
2036: pe "";
2037: pe "//STRUCT and UNION FIELDS";
2038: Hashtbl.iter
2039: (fun k (v,b)->
2040: pe ("fun " ^ k ^ ": " ^v^ " = '" ^ b ^ "';")
2041: )
2042: stab.fields
2043: end
2044: end
2045: ;
2046: pe "}";
2047: close_out outf
2048: ;
2049: match mode with
2050: | `orig -> print_endline ("New file " ^ outname); ()
2051: | `tmp ->
2052: let f1 = force_open_in "new_file" "tmp.tmp" in
2053: let f2 = force_open_in "changed_file" outname in
2054: for i = 1 to 6 do (* skip timestamps when comparing *)
2055: ignore(input_line f1);
2056: ignore(input_line f2)
2057: done
2058: ;
2059: try
2060: while true do
2061: let in1 = try Some (input_line f1) with End_of_file -> None in
2062: let in2 = try Some (input_line f2) with End_of_file -> None in
2063: match in1,in2 with
2064: | None, None -> raise Equal
2065: | Some i, Some j when i = j -> ()
2066: | _ -> raise Not_equal
2067: done
2068: with
2069: | Not_equal ->
2070: begin
2071: print_endline ("Changed file .. " ^ outname);
2072: close_in f1; close_in f2;
2073: let f1 = force_open_in "changed_file" "tmp.tmp" in
2074: let f2 = force_open_out "change_file" outname in
2075: try while true do output_string f2 ((input_line f1) ^ "\n")
2076: done with End_of_file ->
2077: close_in f1; close_out f2
2078: end
2079:
2080: | Equal ->
2081: print_endline ("Unchanged file .. " ^ outname);
2082: close_in f2;
2083: close_in f1
2084: end
2085: fnames
2086: ;;
2087:
2088: if is_nonempty control.incomplete_types_cache then
2089: let outname =
2090: Filename.concat (control.outdir)
2091: ("_incomplete_types_cache.flx")
2092: in
2093: let outf = autocreate outname in
2094: let print_endline s = output_string outf (s ^ "\n") in
2095: print_endline "//incomplete type cache";
2096: print_endline "module _incomplete_types {";
2097: Hashtbl.iter
2098: (fun k (v,m) ->
2099: match m with
2100: | [_] -> ()
2101: | _ ->
2102: print_endline ("incomplete type " ^ k ^ " = '" ^v^ "';");
2103: List.iter
2104: (fun s -> print_endline (" // used by " ^ s)
2105: )
2106: m
2107: )
2108: control.incomplete_types_cache
2109: ;
2110: print_endline "}";
2111: close_out outf
2112: ;;
2113:
2114: let flx f =
2115: if control.flxg_command <> "" then begin
2116: let cmd = control.flxg_command ^ " -I"^control.outdir^" -c " ^f in
2117: print_endline cmd;
2118: Unix.system(cmd)
2119: end
2120: else Unix.WEXITED 0 (* cheat *)
2121: ;;
2122:
2123: let fnames = ref []
2124: ;;
2125:
2126: let rec dflx dir =
2127: try
2128: let f = Unix.opendir dir in
2129: begin
2130: try
2131: while true do let m = Unix.readdir f in
2132: let path = Filename.concat dir m in
2133: let st =
2134: try Unix.lstat path
2135: with _ -> failwith ("Can't lstat " ^ path)
2136: in
2137: match st.Unix.st_kind with
2138: | Unix.S_REG ->
2139: if Filename.check_suffix path ".flx" then
2140: let fn = Filename.chop_suffix path ".flx" in
2141: fnames := fn :: !fnames
2142:
2143: | Unix.S_DIR ->
2144: if not (isprefix "." m) then dflx path
2145: | _ -> ()
2146: done
2147: with End_of_file -> Unix.closedir f
2148: end
2149: with Unix.Unix_error _ ->
2150: failwith ("Can't find directory " ^ dir)
2151: ;;
2152:
2153: dflx control.outdir
2154: ;;
2155:
2156: let fnames = List.sort compare !fnames
2157: ;;
2158: let faulty = ref [];;
2159: let good = ref [];;
2160:
2161: iter
2162: begin fun fn ->
2163: let result = flx fn in
2164: match result with
2165: | Unix.WEXITED 0 -> good := fn :: !good
2166: | Unix.WEXITED i ->
2167: faulty := fn :: !faulty;
2168: print_endline ("***** Failed, error " ^ string_of_int i)
2169: | Unix.WSIGNALED i
2170: | Unix.WSTOPPED i ->
2171: failwith ("SIGNAL " ^ string_of_int i)
2172: end
2173: fnames
2174: ;;
2175:
2176: let f = open_out control.log_filename in
2177: iter
2178: (fun fn ->
2179: output_string f ("FAILED : " ^ fn ^ "\n")
2180: )
2181: (rev !faulty)
2182: ;
2183: iter
2184: (fun fn ->
2185: output_string f ("SUCCEEDED: " ^ fn ^ "\n")
2186: )
2187: (rev !good)
2188: ;
2189: close_out f
2190: ;;
2191: