1: # 22 "./lpsrc/flx_bbind.ipk"
2: open Flx_util
3: open Flx_types
4: open Flx_ast
5: open Flx_mtypes1
6: open Flx_mtypes2
7: open Flx_print
8: open Flx_typing
9: open Flx_lookup
10: open Flx_mbind
11: open Flx_srcref
12: open Flx_unify
13: open Flx_exceptions
14: open Flx_bexe
15: open List
16: open Flx_generic
17: open Flx_tpat
18: open Inria_syntax
19:
20: let find_param name_map s =
21: match Hashtbl.find name_map s with
22: | `NonFunctionEntry (i) -> sye i
23: | _ -> failwith ("[find_param] Can't find parameter " ^ s )
24:
25: let print_bvs vs =
26: if length vs = 0 then "" else
27: "[" ^ catmap "," (fun (s,i) -> s ^ "<"^si i^">") vs^ "]"
28:
29:
30: let bind_regex' syms env sr be ret_type cls : regular_args_t =
31: let irc c = Characters (Inria_cset.singleton (Char.code c)) in
32: let rec inr re = match re with
33: | `REGEXP_code _ -> assert false
34: | `REGEXP_name _ -> assert false
35: | `REGEXP_sentinel -> assert false
36:
37: | `REGEXP_alt (a,b) -> Alternative (inr a, inr b)
38: | `REGEXP_seq (a,b) -> Sequence (inr a, inr b)
39: | `REGEXP_epsilon -> Epsilon
40: | `REGEXP_aster a -> Repetition (inr a)
41: | `REGEXP_group (name,a) -> Bind (inr a,name)
42: | `REGEXP_string s ->
43: if String.length s = 0 then Epsilon
44: else let r = ref (irc s.[0]) in
45: for i = 1 to String.length s -1 do
46: r := Sequence (!r, irc s.[i])
47: done;
48: !r
49: in
50: let cls = map (fun (e,c) -> bind_regdef syms env [] e, c) cls in
51: let lex : (unit, expr_t) Inria_syntax.entry =
52: {
53: name = "dummy"; shortest = false; args=();
54: clauses = map (fun (e,c) -> inr e, c) cls
55: }
56: in
57: let aes, aut = Inria_lexgen.make_dfa [lex] in
58: failwith "Inria dfa built"
59:
60: let bind_regex syms env sr be ret_type cls : regular_args_t =
61: (*
62: print_endline "Binding regmatch";
63: *)
64: let bd e = bind_regdef syms env [] e in
65:
66: (* create a unified regexp using `REGEXP_code for expressions *)
67: let f (e,c) = `REGEXP_seq (e, `REGEXP_code c) in
68: let re = List.map f cls in
69: let alt r1 r2 = `REGEXP_alt (r1,r2) in
70: let re = List.fold_right alt re `REGEXP_sentinel in
71:
72: (* do lookups *)
73: let re = bd re in
74:
75: (* generate transition matrix *)
76: let alphabet, nstates, code_table, matrix = Flx_dfa.process_regexp re in
77: let alphabet = CharSet.elements alphabet in
78:
79: (* bind RHS expressions *)
80: let bcode = Hashtbl.create 97 in
81: Hashtbl.iter
82: (fun i c ->
83: let sr = src_of_expr c in
84: let e,t as bt = be c in
85: let t = minimise syms.dfns t in
86: Hashtbl.add bcode i (e,t);
87: if do_unify syms !ret_type t then
88: ret_type := varmap_subst syms.varmap !ret_type
89: else
90: clierr sr
91: (
92: "[bind_regex] Wrong return type,\nexpected : " ^
93: string_of_btypecode syms.dfns !ret_type ^
94: "\nbut we got " ^
95: string_of_btypecode syms.dfns t ^ " in\n" ^
96: short_string_of_src sr
97: )
98: )
99: code_table
100: ;
101: alphabet,nstates, bcode,matrix
102:
103: let rec find_true_parent dfns child parent =
104: match parent with
105: | None -> None
106: | Some parent ->
107: match Hashtbl.find dfns parent with
108: | {id=id; parent=grandparent; symdef=bdcl} ->
109: match bdcl with
110: | `SYMDEF_module
111: -> find_true_parent dfns id grandparent
112: | _ -> Some parent
113:
114: let bind_req syms env sr tag =
115: (* HACKY *)
116: try Some (lookup_code_in_env syms env sr tag)
117: with _ -> None
118:
119:
120: (* this routine converts a requirements expression into a list
121: of requirements. Note later if we have conflicts (negation),
122: we'll need to also return a list of requirements that
123: would generate a conflict
124:
125: NOTE weird encoding: -1,[] is true (always satisfied)
126: and -2,[] is false (impossible to satisfy)
127: *)
128:
129: let bind_reqs bt syms env sr reqs : (bid_t * btypecode_t list) list =
130: let add lst i =
131: if
132: lst = [-2,[]] or
133: mem i lst or
134: i = (0,[])
135: then lst else i :: lst
136: in
137: let merge a b = fold_left add a b in
138: let rec aux reqs = match reqs with
139: | `NREQ_true -> []
140: | `NREQ_false -> [-2,[]]
141: | `NREQ_and (a,b) -> merge (aux a) (aux b)
142: | `NREQ_or (a,b) ->
143: let a = aux a and b = aux b in
144: if a = [-2,[]] then b else a
145:
146: | `NREQ_atom tag ->
147: match bind_req syms env sr tag with
148: | None -> [-2,[]]
149: | Some (entries, ts) ->
150: let ts = map bt ts in
151: fold_left (fun lst index ->
152: let index = sye index in
153: if index = 0 then lst else
154: let ts = adjust_ts syms sr index ts in
155: add lst (index,ts)
156: ) [] entries
157: in
158: let res = aux reqs in
159: res
160:
161: let bind_qual bt qual = match qual with
162: | #base_type_qual_t as x -> x
163: | `Raw_needs_shape t -> `Bound_needs_shape (bt t)
164:
165: let bind_quals bt quals = map (bind_qual bt) quals
166:
167: let bbind_sym syms bbdfns i {
168: id=name;
169: sr=sr;
170: parent=parent;
171: vs=local_vs;
172: privmap=name_map;
173: dirs=dirs;
174: symdef=bdcl
175: } =
176: let qname = qualified_name_of_index syms.dfns i in
177: let true_parent = find_true_parent syms.dfns name parent in
178: let bexes env exes rt i tvars = bind_exes syms env sr exes rt name i tvars in
179: (*
180: print_endline ("Binding " ^ name ^ "<"^ si i ^ ">");
181: print_endline ("Parent is " ^ (match parent with | None -> "none" | Some i -> si i));
182: print_endline ("True Parent is " ^ (match true_parent with | None -> "none" | Some i -> si i));
183: *)
184: begin
185: (* let env = build_env syms parent in *)
186: let env = build_env syms (Some i) in
187: (*
188: print_endline "ENVIRONMENT:";
189: print_env_short env;
190: *)
191:
192: let be e = bind_expression syms env e in
193: let luqn n = lookup_qn_in_env syms env n in
194: let luqn2 n = lookup_qn_in_env2 syms env n in
195: let bt t = bind_type syms env sr t in
196: let ivs = find_vs syms i in (* this is the full vs list *)
197: let bvs = map (fun (s,i,tp) -> s,i) (fst ivs) in
198: let bind_type_constraint ivs =
199: let cons = try
200: Flx_tconstraint.build_type_constraints syms bt sr (fst ivs)
201: with _ -> clierr sr "Can't build type constraints, type binding failed"
202: in
203: let {raw_type_constraint=icons} = snd ivs in
204: let icons = bt icons in
205: let cons = `BTYP_intersect [cons; icons] in
206: cons
207: in
208: let bcons = bind_type_constraint ivs in
209: let btraint = function | Some x -> Some (be x) | None -> None in
210: let bind_reqs reqs = bind_reqs bt syms env sr reqs in
211: let bind_quals quals = bind_quals bt quals in
212: (*
213: print_endline ("******Binding " ^ name);
214: *)
215: let bind_basic_ps ps =
216: List.map (fun (k,s,t) ->
217: let i = find_param name_map s in
218: {pid=s; pindex=i;pkind=k; ptyp=bt t}
219: )
220: ps
221: in
222: let bindps (ps,traint) =
223: bind_basic_ps ps, btraint traint
224: in
225: match bdcl with
226:
227: (* Pure declarations of functions, modules, and type
228: don't generate anything. Variable dcls do, however.
229: *)
230: | `SYMDEF_module
231: | `SYMDEF_typevar _
232: -> ()
233:
234: | `SYMDEF_reduce (ps,e1,e2) ->
235: let bps = bind_basic_ps ps in
236: let be1 = be e1 in
237: let be2 = be e2 in
238: syms.reductions <- (name,bvs,bps,be1,be2) :: syms.reductions
239: ;
240: if syms.compiler_options.print_flag then
241: print_endline ("//bound reduction " ^ name ^ "<"^si i^">" ^
242: print_bvs bvs)
243:
244: | `SYMDEF_axiom (ps,e1) ->
245: let bps = bindps ps in
246: let be1 = match e1 with
247: | `Predicate e -> `BPredicate (be e)
248: | `Equation (l,r) -> `BEquation (be l, be r)
249: in
250: syms.axioms <- (name,sr,parent,`Axiom, bvs,bps,be1) :: syms.axioms
251: ;
252: if syms.compiler_options.print_flag then
253: print_endline ("//bound axiom " ^ name ^ "<"^si i^">" ^
254: print_bvs bvs)
255:
256: | `SYMDEF_lemma (ps,e1) ->
257: let bps = bindps ps in
258: let be1 = match e1 with
259: | `Predicate e -> `BPredicate (be e)
260: | `Equation (l,r) -> `BEquation (be l, be r)
261: in
262: syms.axioms <- (name,sr,parent,`Lemma, bvs,bps,be1) :: syms.axioms
263: ;
264: if syms.compiler_options.print_flag then
265: print_endline ("//bound lemma " ^ name ^ "<"^si i^">" ^
266: print_bvs bvs)
267:
268: | `SYMDEF_function (ps,rt,props,exes) ->
269: let bps = bindps ps in
270: let ts = typeofbps_traint bps in
271: let brt = bt rt in
272: let brt',bbexes = bexes env exes brt i bvs in
273: let bbdcl =
274: match brt' with
275: | `BTYP_void ->
276: `BBDCL_procedure (props,bvs,bps,bbexes)
277: | _ ->
278: `BBDCL_function (props,bvs,bps,brt',bbexes)
279: in
280: Hashtbl.add bbdfns i (name,true_parent,sr,bbdcl);
281: begin
282: if not (Hashtbl.mem syms.ticache i) then
283: let d = typeoflist ts in
284: let ft =
285: if mem `Cfun props
286: then `BTYP_cfunction (d,brt')
287: else `BTYP_function (d,brt')
288: in
289: let t = fold syms.dfns ft in
290: Hashtbl.add syms.ticache i t
291: end
292: ;
293: let atyp = typeoflist ts in
294: if syms.compiler_options.print_flag then
295: let t =
296: if mem `Cfun props
297: then `BTYP_cfunction (atyp,brt')
298: else `BTYP_function (atyp,brt')
299: in
300: print_endline
301: (
302: "//bound function " ^ qname ^ "<"^si i^">" ^
303: print_bvs bvs ^":" ^
304: sbt syms.dfns t
305: )
306:
307: | `SYMDEF_parameter (k,_) ->
308: begin match parent with
309: | None -> failwith "[bbind_sym] expected parameter to have a parent"
310: | Some ip ->
311: match Hashtbl.find syms.dfns ip with
312: | {symdef=`SYMDEF_reduce _}
313: | {symdef=`SYMDEF_axiom _}
314: | {symdef=`SYMDEF_lemma _}
315: | {symdef=`SYMDEF_function _}
316: | {symdef=`SYMDEF_regmatch _}
317: | {symdef=`SYMDEF_reglex _}
318: ->
319: let t = typeofindex syms i in
320: let dcl = match k with
321: | `PVar -> `BBDCL_var (bvs,t)
322: | `PVal -> `BBDCL_val (bvs,t)
323: | `PRef -> `BBDCL_ref (bvs,t)
324: | `PFun -> `BBDCL_val (bvs,`BTYP_function (`BTYP_void,t))
325: in
326: Hashtbl.add bbdfns i (name,true_parent,sr,dcl);
327: Hashtbl.add syms.varmap i t;
328:
329: if syms.compiler_options.print_flag then
330: print_endline ("//bound val " ^ name ^ "<"^si i^">" ^
331: print_bvs bvs ^ ":" ^
332: sbt syms.dfns t)
333:
334: | _ -> failwith "[bbind_sym] expected parameter to have function or functor parent"
335: end
336:
337: | `SYMDEF_match_check (pat,(mvname,mvindex)) ->
338: let t = typeofindex syms mvindex in
339: let name_map = Hashtbl.create 97 in
340: let exes =
341: [
342: sr,`EXE_fun_return (gen_match_check pat (`AST_index (sr,mvname,mvindex)))
343: ]
344: in
345: let brt',bbexes = bexes env exes flx_bbool i [] in
346: if brt' <> flx_bbool
347: then
348: failwith
349: (
350: "expected boolean return from match checker " ^ name ^ " in\n" ^
351: short_string_of_src sr
352: )
353: ;
354: Hashtbl.add bbdfns i (name,true_parent,sr,
355: `BBDCL_function ([`Inline; `Generated "bbind: match check"],bvs,([],None),flx_bbool,bbexes)
356: );
357: begin
358: if not (Hashtbl.mem syms.ticache i) then
359: let t = fold syms.dfns (`BTYP_function (`BTYP_tuple[],flx_bbool)) in
360: Hashtbl.add syms.ticache i t
361: end
362: ;
363:
364: if syms.compiler_options.print_flag then
365: print_endline ("//bound match check " ^ name ^ "<"^si i^">" ^
366: print_bvs bvs ^ ":" ^
367: sbt syms.dfns (`BTYP_function (`BTYP_tuple[],flx_bbool))
368: )
369:
370: (*
371: | `SYMDEF_regexp _ -> ()
372: *)
373:
374: | `SYMDEF_regmatch (ps,cls) ->
375: let bps = bindps ps in
376: let ts = typeofbps_traint bps in
377: let ret_type = ref (snd (be (snd (hd cls)))) in
378: let bregex = bind_regex syms env sr be ret_type cls in
379: let bbdcl = `BBDCL_regmatch ([],bvs,bps,!ret_type,bregex) in
380: Hashtbl.add bbdfns i (name,true_parent,sr,bbdcl)
381: ;
382: begin
383: if not (Hashtbl.mem syms.ticache i) then
384: let t = fold syms.dfns (`BTYP_function (typeoflist ts,!ret_type)) in
385: Hashtbl.add syms.ticache i t
386: end
387: ;
388: if syms.compiler_options.print_flag then
389: print_endline ("//bound regmatch " ^ name ^ "<"^si i^">" )
390:
391:
392: | `SYMDEF_reglex (ps,le,cls) ->
393: let bps = bindps ps in
394: let ts = typeofbps_traint bps in
395: let ret_type = ref (snd (be (snd (hd cls)))) in
396: let bregex = bind_regex syms env sr be ret_type cls in
397: let bbdcl = `BBDCL_reglex ([],bvs,bps,le,!ret_type,bregex) in
398: Hashtbl.add bbdfns i (name,true_parent,sr,bbdcl)
399: ;
400: begin
401: if not (Hashtbl.mem syms.ticache i) then
402: let t = fold syms.dfns (`BTYP_function (typeoflist ts,!ret_type)) in
403: Hashtbl.add syms.ticache i t
404: end
405: ;
406: if syms.compiler_options.print_flag then
407: print_endline ("//bound reglex " ^ name ^ "<"^si i^">" )
408:
409: | `SYMDEF_glr (t,(p,exes)) ->
410: (*
411: print_endline ("Binding nonterm " ^ name ^"<"^ si i ^">");
412: *)
413: let brt = if t = `TYP_none then `BTYP_var (i,`BTYP_type 0) else bt t in
414: (*
415: print_endline ("Specified type " ^ sbt syms.dfns brt);
416: *)
417: (*
418: let brt = `BTYP_var i in (* hack .. *)
419: *)
420:
421: let bn q =
422: (* we have to check this .. *)
423: match luqn2 q with
424: | `FunctionEntry [i],[] ->
425: let i = sye i in
426: begin match Hashtbl.find syms.dfns i with
427: | {symdef=`SYMDEF_glr _ } -> `Nonterm [i]
428: | {symdef=`SYMDEF_nonconst_ctor _} -> `Term i
429: | _ -> clierr sr "Expected nonterminal or union constructor"
430: end
431: | `FunctionEntry ii,[] ->
432: let ii = map sye ii in
433: let i = hd ii in
434: begin match Hashtbl.find syms.dfns i with
435: | {symdef=`SYMDEF_glr _ } -> `Nonterm ii
436: | {symdef=`SYMDEF_nonconst_ctor _} ->
437: clierr sr "Expected unique union constructor (it's overloaded)"
438: | _ -> clierr sr "Expected nonterminal or union constructor"
439: end
440: | `NonFunctionEntry i,[] -> `Term (sye i)
441: | _,ts -> clierr sr "Unexpected type variables"
442: in
443: let bp p = map (fun (n,q) -> n,bn q) p in
444: let p = bp p in
445: let brt',bbexes = bexes env exes brt i bvs in
446: let bbdcl = `BBDCL_glr ([],bvs,brt',(p, bbexes)) in
447: Hashtbl.add bbdfns i (name,true_parent,sr,bbdcl);
448:
449: if syms.compiler_options.print_flag then
450: print_endline ("//bound glr " ^ name ^ "<"^si i^">" )
451:
452: | `SYMDEF_const_ctor (uidx,ut,ctor_idx,vs') ->
453: (*
454: print_endline ("Binding const ctor " ^ name);
455: *)
456: let unit_sum =
457: match Hashtbl.find syms.dfns uidx with
458: | {symdef=`SYMDEF_union its} ->
459: fold_left
460: (fun v (_,_,_,t) ->
461: v && (match t with `AST_void _ -> true | _ -> false)
462: )
463: true
464: its
465: | _ -> assert false
466: in
467: let t = typeofindex syms i in
468: let ut = bt ut in
469: let ct =
470: if unit_sum then si ctor_idx
471: else "_uctor_(" ^ si ctor_idx ^ ",0)"
472: in
473: Hashtbl.add bbdfns i (name,None,sr,`BBDCL_const (bvs,t,`Str ct,[]));
474:
475: if syms.compiler_options.print_flag then
476: print_endline ("//bound const " ^ name ^ "<"^si i^">:" ^
477: sbt syms.dfns t)
478:
479: | `SYMDEF_nonconst_ctor (uidx,ut,ctor_idx,vs',argt) ->
480: (*
481: print_endline ("Binding non const ctor " ^ name);
482: *)
483: let t = typeofindex syms i in
484: let argt = bt argt in
485: let ut = bt ut in
486: let btraint = bind_type_constraint vs' in
487: let evs = map (fun (s,i,__) -> s,i) (fst vs') in
488: let bbdcl = `BBDCL_nonconst_ctor (bvs,uidx,ut,ctor_idx,argt,evs,btraint) in
489: Hashtbl.add bbdfns i (name,None,sr,bbdcl);
490:
491: if syms.compiler_options.print_flag then
492: print_endline ("//bound fun " ^ name ^ "<"^si i^">:" ^
493: sbt syms.dfns t)
494:
495: | `SYMDEF_val (t) ->
496: let t = typeofindex syms i in
497: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_val (bvs,t));
498:
499: if syms.compiler_options.print_flag then
500: print_endline ("//bound val " ^ name ^ "<"^si i^">" ^
501: print_bvs bvs ^ ":" ^
502: sbt syms.dfns t)
503:
504: | `SYMDEF_ref (t) ->
505: let t = typeofindex syms i in
506: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_ref (bvs,t));
507:
508: if syms.compiler_options.print_flag then
509: print_endline ("//bound ref " ^ name ^ "<"^si i^">" ^
510: print_bvs bvs ^ ":" ^
511: sbt syms.dfns t)
512:
513: | `SYMDEF_lazy (rt,e) ->
514: let ps = [("dummy",`AST_void sr)],None in
515: let exes = [sr,`EXE_fun_return e] in
516: let brt = bt rt in
517: let brt',bbexes = bexes env exes brt i bvs in
518: let props = [] in
519: let bbdcl =
520: `BBDCL_function (props,bvs,([],None),brt',bbexes)
521: in
522: Hashtbl.add bbdfns i (name,true_parent,sr,bbdcl);
523: begin
524: if not (Hashtbl.mem syms.ticache i) then
525: (* HACK! *)
526: Hashtbl.add syms.ticache i brt'
527: end
528: ;
529: if syms.compiler_options.print_flag then
530: print_endline ("//bound lazy " ^ name ^ "<"^si i^">" ^
531: print_bvs bvs ^ ":" ^
532: sbt syms.dfns brt')
533:
534: | `SYMDEF_var (t) ->
535: (*
536: print_endline ("Binding variable " ^ name ^"<"^ si i ^">");
537: *)
538: let t = typeofindex syms i in
539: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_var (bvs, t))
540: ;
541: if syms.compiler_options.print_flag then
542: print_endline ("//bound var " ^ name ^ "<"^si i^">" ^
543: print_bvs bvs ^ ":" ^
544: sbt syms.dfns t)
545:
546: | `SYMDEF_const (t,ct,reqs) ->
547: let t = typeofindex syms i in
548: let reqs = bind_reqs reqs in
549: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_const (bvs,t,ct,reqs));
550: if syms.compiler_options.print_flag then
551: print_endline ("//bound const " ^ name ^ "<"^si i^">" ^
552: print_bvs bvs ^ ":" ^
553: sbt syms.dfns t)
554:
555:
556: | `SYMDEF_fun (props,ts,ret,ct,reqs,prec) ->
557: let ts = map bt ts in
558: let bret = bt ret in
559: let reqs = bind_reqs reqs in
560: let bbdcl = match bret with
561: | `BTYP_void ->
562: `BBDCL_proc (props,bvs,ts,ct,reqs)
563: | _ ->
564: `BBDCL_fun (props,bvs,ts,bret,ct,reqs,prec)
565: in
566: Hashtbl.add bbdfns i (name,true_parent,sr,bbdcl);
567: begin
568: if not (Hashtbl.mem syms.ticache i) then
569: let t = fold syms.dfns (`BTYP_function (typeoflist ts,bret)) in
570: Hashtbl.add syms.ticache i t
571: end
572: ;
573: let atyp = typeoflist ts in
574: if syms.compiler_options.print_flag then
575: print_endline ("//bound fun " ^ name ^ "<"^si i^">"^
576: print_bvs bvs ^ ":" ^
577: sbt syms.dfns (`BTYP_function (atyp,bret)))
578:
579: | `SYMDEF_callback (props,ts_orig,ret,reqs) ->
580:
581: let bret = bt ret in
582:
583: (* The type of the raw C function's arguments,
584: using address = void* for the callback.
585: This is the one passed to C, and the one we generate
586: to cast the address to a Felix type and then execute it.
587:
588: Note the hack .. binding to C_hack::address .. it isn't
589: necessary because we know it's a void*, but there is no
590: builtin symbol for that.
591:
592: This is the function the user must call to actually
593: invoke the Felix callback passed to it.
594:
595: A callback is much like an exported function,
596: in that it binds a function to some arguments
597: from a C call, however it is passed a closure,
598: whereas exported functions create their own.
599:
600: This function isn't type safe to call at the C
601: level, but it has the correct type to PASS to
602: the usual establishing functions (or pointer to
603: function in a struct)
604:
605: this is an extern "C" function with the original
606: name. The name isn't mangled, and so shouldn't
607: conflict with the typesafe ts_cf below.
608: *)
609: let client_data_pos = ref (-1) in
610: let ts_c =
611: let counter = ref 0 in
612: map
613: (function
614: | `AST_name (_,id,[]) when id = name ->
615: if !client_data_pos = -1 then
616: client_data_pos := !counter
617: ;
618: let address = `AST_name(sr,"address",[]) in
619: bt address
620: | t -> incr counter; bt t
621: )
622: ts_orig
623: in
624:
625: (* The type of the arguments of the Felix callback function,
626: which are the same as the C function, but with the client
627: data pointer dropped
628: *)
629: let ts_f =
630: map bt
631: (
632: filter
633: (function
634: | `AST_name (_,id,[]) when id = name -> false
635: | t -> true
636: )
637: ts_orig
638: )
639: in
640: let tf_args = match ts_f with
641: | [x] -> x
642: | lst -> `BTYP_tuple lst
643: in
644: let tf = `BTYP_function (tf_args, bret) in
645:
646: (* The type of the arguments Felix thinks the raw
647: C function has on a call. A closure of this
648: function is a Felix function .. NOT the raw
649: C function.
650: *)
651: let ts_cf =
652: map
653: (function
654: | `AST_name (_,id,[]) when id = name -> tf
655: | t -> bt t
656: )
657: ts_orig
658: in
659:
660: let prec = "postfix" in
661: let reqs = bind_reqs reqs in
662:
663: let bbdcl = `BBDCL_callback (props,bvs,ts_cf,ts_c,!client_data_pos,bret,reqs,prec) in
664: Hashtbl.add bbdfns i (name,true_parent,sr,bbdcl);
665: begin
666: if not (Hashtbl.mem syms.ticache i) then
667: let t = fold syms.dfns (`BTYP_cfunction (typeoflist ts_cf,bret)) in
668: Hashtbl.add syms.ticache i t
669: end
670: ;
671: let atyp = typeoflist ts_cf in
672: if syms.compiler_options.print_flag then
673: print_endline ("//bound callback fun " ^ name ^ "<"^si i^">"^
674: print_bvs bvs ^ ":" ^
675: sbt syms.dfns (`BTYP_function (atyp,bret)))
676:
677: | `SYMDEF_union (cs) ->
678: (*
679: print_endline ("//Binding union " ^ si i ^ " --> " ^ name);
680: *)
681: let cs' = List.map (fun (n,v,vs',t) -> n, v,bt t) cs in
682: Hashtbl.add bbdfns i (name,None,sr,`BBDCL_union (bvs,cs'))
683:
684: | `SYMDEF_struct (cs) ->
685: (* print_endline ("//Binding struct " ^ si i ^ " --> " ^ name);
686: *)
687: let cs' = List.map (fun (n,t) -> n, bt t) cs in
688: Hashtbl.add bbdfns i (name,None,sr,`BBDCL_struct (bvs,cs'))
689:
690: | `SYMDEF_cstruct (cs) ->
691: (* print_endline ("//Binding cstruct " ^ si i ^ " --> " ^ name);
692: *)
693: let cs' = List.map (fun (n,t) -> n, bt t) cs in
694: Hashtbl.add bbdfns i (name,None,sr,`BBDCL_cstruct (bvs,cs'))
695:
696: | `SYMDEF_cclass (cs) ->
697: (* NOTE: At present the code spec is already handled by symtab,
698: so there is point propagating it .. the bound members are kept
699: to ensure we generate all required types, they don't generate
700: any actual code
701: *)
702:
703: (*
704: (* DUMMY type variable index here!! FIX ME !!!! *)
705: let vs2bvs (s,_) = let i = 0 in s,i in
706: let cs' =
707: List.map (function
708: | `MemberVal (n,t,_) -> `BMemberVal (n, bt t)
709: | `MemberVar (n,t,_) -> `BMemberVar (n, bt t)
710: | `MemberFun (n,vs,t,_) -> `BMemberFun (n, map vs2bvs vs, bt t)
711: | `MemberProc (n,vs,t,_) -> `BMemberProc (n, map vs2bvs vs, bt t)
712: | `MemberCtor (n,t,_) -> `BMemberCtor (n, bt t)
713: )
714: cs
715: in
716: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_cclass (bvs,cs'))
717: *)
718:
719: (* temporary hack, elide interface .. *)
720: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_cclass (bvs,[]))
721:
722: | `SYMDEF_class ->
723: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_class ([],bvs))
724:
725: | `SYMDEF_typeclass ->
726: let sym : bbdcl_t = `BBDCL_typeclass ([],bvs) in
727: Hashtbl.add bbdfns i (name,true_parent,sr,sym)
728:
729: | `SYMDEF_instance qn ->
730: (*
731: print_endline "INSTANCE";
732: *)
733: let (k:entry_kind_t),(ts: typecode_t list) = luqn qn in
734: let k = sye k in
735: (*
736: print_endline ("binding ts = " ^ catmap "," string_of_typecode ts);
737: *)
738: let ts = map bt ts in
739: (*
740: print_endline "DOne ..";
741: *)
742: let sym : bbdcl_t = `BBDCL_instance ([],bvs,bcons, k,ts) in
743: Hashtbl.add bbdfns i (name,true_parent,sr,sym)
744:
745: | `SYMDEF_regdef _ -> ()
746: | `SYMDEF_type_alias _ -> ()
747: | `SYMDEF_inherit _ -> ()
748: | `SYMDEF_inherit_fun _ -> ()
749:
750: | `SYMDEF_abs (quals,ct,reqs)->
751: (*
752: print_endline ("//Binding abstract type " ^ si i ^ " --> " ^ name);
753: *)
754: let reqs = bind_reqs reqs in
755: let bquals = bind_quals quals in
756: Hashtbl.add bbdfns i (name,None,sr,`BBDCL_abs (bvs,bquals,ct,reqs))
757:
758: | `SYMDEF_newtype t ->
759: let t = bt t in
760: Hashtbl.add bbdfns i (name,None,sr,`BBDCL_newtype (bvs,t))
761:
762: | `SYMDEF_insert (ct,ikind,reqs) ->
763: (* print_endline ("//Binding header string " ^ si i ^ " --> " ^ name);
764: *)
765: let reqs = bind_reqs reqs in
766: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_insert (bvs,ct,ikind,reqs))
767:
768: end
769: (*
770: ;
771: print_endline ("BINDING " ^ name ^ "<" ^ si i ^ "> COMPLETE");
772: flush stdout
773: *)
774:
775: let bbind_index syms bbdfns i =
776: if Hashtbl.mem bbdfns i then ()
777: else let entry = Hashtbl.find syms.dfns i in
778: bbind_sym syms bbdfns i entry
779:
780: let bbind syms =
781: let bbdfns = Hashtbl.create 97 in
782: (* loop through all counter values [HACK]
783: to get the indices in sequence, AND,
784: to ensure any instantiations will be bound,
785: (since they're always using the current value
786: of syms.counter for an index
787: *)
788: let i = ref 0 in
789: while !i < !(syms.counter) do
790: begin
791: let entry =
792: try Some (Hashtbl.find syms.dfns !i)
793: with Not_found -> None
794: in match entry with
795: | Some entry ->
796: begin try
797: (*
798: begin
799: try match Hashtbl.find syms.dfns !i with {id=id} ->
800: print_endline (" Trying to bind "^id^" index " ^ si !i)
801: with Not_found ->
802: failwith ("Binding error UNKNOWN SYMBOL, index " ^ si !i)
803: end
804: ;
805: *)
806: bbind_sym syms bbdfns !i entry
807: with Not_found ->
808: try match Hashtbl.find syms.dfns !i with {id=id} ->
809: failwith ("Binding error "^id^" index " ^ si !i)
810: with Not_found ->
811: failwith ("Binding error UNKNOWN SYMBOL, index " ^ si !i)
812: end
813: | None -> ()
814: end
815: ;
816: incr i
817: done
818: ;
819: bbdfns
820:
821: let bind_ifaces syms
822: (ifaces:
823: (range_srcref * iface_t * int option) list
824: )
825: =
826: let luqn env n = lookup_qn_in_env syms env n in
827: let bound_ifaces =
828: List.map
829: (function
830: | sr,`IFACE_export_fun (sn, cpp_name), parent ->
831: let env = build_env syms parent in
832: let index,ts = lookup_sn_in_env syms env sn in
833: if length ts = 0 then
834: `BIFACE_export_fun (sr,index, cpp_name)
835: else clierr sr
836: (
837: "Can't export generic entity " ^
838: string_of_suffixed_name sn
839: )
840:
841: | sr,`IFACE_export_type (typ, cpp_name), parent ->
842: let env = build_env syms parent in
843: let t = bind_type syms env dummy_sr typ in
844: if try var_occurs t with _ -> true then
845: clierr sr
846: (
847: "Can't export generic- or meta- type " ^
848: string_of_btypecode syms.dfns t
849: )
850: else
851: `BIFACE_export_type (sr, t, cpp_name)
852: )
853: ifaces
854: in bound_ifaces
855:
856: