1: # 28 "./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) -> 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 -> find_true_parent dfns id grandparent
111: | `SYMDEF_regmatch _
112: | `SYMDEF_reglex _
113: | `SYMDEF_function _
114: | `SYMDEF_class -> Some parent
115: | _ -> None
116:
117: let bind_req syms env sr tag =
118: (* HACKY *)
119: try Some (lookup_code_in_env syms env sr tag)
120: with _ -> None
121:
122:
123: (* this routine converts a requirements expression into a list
124: of requirements. Note later if we have conflicts (negation),
125: we'll need to also return a list of requirements that
126: would generate a conflict
127:
128: NOTE weird encoding: -1,[] is true (always satisfied)
129: and -2,[] is false (impossible to satisfy)
130: *)
131:
132: let bind_reqs bt syms env sr reqs : (bid_t * btypecode_t list) list =
133: let add lst i =
134: if
135: lst = [-2,[]] or
136: mem i lst or
137: i = (0,[])
138: then lst else i :: lst
139: in
140: let merge a b = fold_left add a b in
141: let rec aux reqs = match reqs with
142: | `NREQ_true -> []
143: | `NREQ_false -> [-2,[]]
144: | `NREQ_and (a,b) -> merge (aux a) (aux b)
145: | `NREQ_or (a,b) ->
146: let a = aux a and b = aux b in
147: if a = [-2,[]] then b else a
148:
149: | `NREQ_atom tag ->
150: match bind_req syms env sr tag with
151: | None -> [-2,[]]
152: | Some (entries, ts) ->
153: let ts = map bt ts in
154: fold_left (fun lst index ->
155: if index = 0 then lst else
156: let ts = adjust_ts syms sr index ts in
157: add lst (index,ts)
158: ) [] entries
159: in
160: let res = aux reqs in
161: res
162:
163: let bind_qual bt qual = match qual with
164: | #base_type_qual_t as x -> x
165: | `Raw_needs_shape t -> `Bound_needs_shape (bt t)
166:
167: let bind_quals bt quals = map (bind_qual bt) quals
168:
169: let bbind_sym syms bbdfns i {id=name;sr=sr;parent=parent;vs=local_vs;privmap=name_map;dirs=dirs;symdef=bdcl} =
170: let qname = qualified_name_of_index syms.dfns i in
171: let true_parent = find_true_parent syms.dfns name parent in
172: let bexes env exes rt i tvars = bind_exes syms env sr exes rt name i tvars in
173: (*
174: print_endline ("Binding " ^ name ^ "<"^ si i ^ ">");
175: print_endline ("Parent is " ^ (match parent with | None -> "none" | Some i -> si i));
176: *)
177: begin
178: (* let env = build_env syms parent in *)
179: let env = build_env syms (Some i) in
180: (*
181: print_endline "ENVIRONMENT:";
182: print_env_short env;
183: *)
184:
185: let be e = bind_expression syms env e in
186: let luqn n = lookup_qn_in_env syms env n in
187: let luqn2 n = lookup_qn_in_env2 syms env n in
188: let bt t = bind_type syms env sr t in
189: let ivs = find_vs syms i in (* this is the full vs list *)
190: let bvs = map (fun (s,i,tp) -> s,i) ivs in
191: let btraint = function | Some x -> Some (be x) | None -> None in
192: let bind_reqs reqs = bind_reqs bt syms env sr reqs in
193: let bind_quals quals = bind_quals bt quals in
194: (*
195: print_endline ("******Binding " ^ name);
196: *)
197: let bind_basic_ps ps =
198: List.map (fun (s,t) ->
199: let i = find_param name_map s in
200: s,(i,bt t))
201: ps
202: in
203: let bindps (ps,traint) =
204: bind_basic_ps ps, btraint traint
205: in
206: match bdcl with
207:
208: (* Pure declarations of functions, modules, and type
209: don't generate anything. Variable dcls do, however.
210: *)
211: | `SYMDEF_module
212: | `SYMDEF_typevar _
213: -> ()
214:
215: | `SYMDEF_reduce (ps,e1,e2) ->
216: let bps = bind_basic_ps ps in
217: let be1 = be e1 in
218: let be2 = be e2 in
219: syms.reductions <- (name,bvs,bps,be1,be2) :: syms.reductions
220: ;
221: if syms.compiler_options.print_flag then
222: print_endline ("//bound reduction " ^ name ^ "<"^si i^">" ^
223: print_bvs bvs)
224:
225: | `SYMDEF_axiom (ps,e1) ->
226: let bps = bind_basic_ps ps in
227: let be1 = be e1 in
228: syms.axioms <- (name,sr,bvs,bps,be1) :: syms.axioms
229: ;
230: if syms.compiler_options.print_flag then
231: print_endline ("//bound axiom " ^ name ^ "<"^si i^">" ^
232: print_bvs bvs)
233:
234: | `SYMDEF_function (ps,rt,props,exes) ->
235: let bps = bindps ps in
236: let ts = map (fun (s,(i,t)) -> t) (fst bps) in
237: let brt = bt rt in
238: let brt',bbexes = bexes env exes brt i bvs in
239: let bbdcl =
240: match brt' with
241: | `BTYP_void ->
242: `BBDCL_procedure (props,bvs,bps,bbexes)
243: | _ ->
244: `BBDCL_function (props,bvs,bps,brt',bbexes)
245: in
246: Hashtbl.add bbdfns i (name,true_parent,sr,bbdcl);
247: begin
248: if not (Hashtbl.mem syms.ticache i) then
249: let t = fold syms.dfns (`BTYP_function (typeoflist ts,brt')) in
250: Hashtbl.add syms.ticache i t
251: end
252: ;
253: let atyp = typeoflist (map (fun (s,(i,t)) -> t) (fst bps)) in
254: if syms.compiler_options.print_flag then
255: print_endline
256: (
257: "//bound function " ^ qname ^ "<"^si i^">" ^
258: print_bvs bvs ^":" ^
259: sbt syms.dfns (`BTYP_function (atyp,brt'))
260: )
261:
262: | `SYMDEF_parameter (t) ->
263: begin match parent with
264: | None -> failwith "[bbind_sym] expected parameter to have a parent"
265: | Some ip ->
266: match Hashtbl.find syms.dfns ip with
267: | {symdef=`SYMDEF_reduce _}
268: | {symdef=`SYMDEF_axiom _}
269: | {symdef=`SYMDEF_function _}
270: | {symdef=`SYMDEF_regmatch _}
271: | {symdef=`SYMDEF_reglex _}
272: ->
273: let t = typeofindex syms i in
274: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_val (bvs,t));
275: Hashtbl.add syms.varmap i t;
276:
277: if syms.compiler_options.print_flag then
278: print_endline ("//bound val " ^ name ^ "<"^si i^">" ^
279: print_bvs bvs ^ ":" ^
280: sbt syms.dfns t)
281:
282: | _ -> failwith "[bbind_sym] expected parameter to have function or functor parent"
283: end
284:
285: | `SYMDEF_match_check (pat,(mvname,mvindex)) ->
286: let t = typeofindex syms mvindex in
287: let name_map = Hashtbl.create 97 in
288: let exes =
289: [
290: sr,`EXE_fun_return (gen_match_check pat (`AST_index (sr,mvname,mvindex)))
291: ]
292: in
293: let brt',bbexes = bexes env exes flx_bbool i [] in
294: if brt' <> flx_bbool
295: then
296: failwith
297: (
298: "expected boolean return from match checker " ^ name ^ " in\n" ^
299: short_string_of_src sr
300: )
301: ;
302: Hashtbl.add bbdfns i (name,true_parent,sr,
303: `BBDCL_function ([`Inline; `Generated "bbind: match check"],bvs,([],None),flx_bbool,bbexes)
304: );
305: begin
306: if not (Hashtbl.mem syms.ticache i) then
307: let t = fold syms.dfns (`BTYP_function (`BTYP_tuple[],flx_bbool)) in
308: Hashtbl.add syms.ticache i t
309: end
310: ;
311:
312: if syms.compiler_options.print_flag then
313: print_endline ("//bound match check " ^ name ^ "<"^si i^">" ^
314: print_bvs bvs ^ ":" ^
315: sbt syms.dfns (`BTYP_function (`BTYP_tuple[],flx_bbool))
316: )
317:
318: (*
319: | `SYMDEF_regexp _ -> ()
320: *)
321:
322: | `SYMDEF_regmatch (ps,cls) ->
323: let bps = bindps ps in
324: let ts = map (fun (s,(i,t)) -> t) (fst bps) in
325: let ret_type = ref (snd (be (snd (hd cls)))) in
326: let bregex = bind_regex syms env sr be ret_type cls in
327: let bbdcl = `BBDCL_regmatch ([],bvs,bps,!ret_type,bregex) in
328: Hashtbl.add bbdfns i (name,true_parent,sr,bbdcl)
329: ;
330: begin
331: if not (Hashtbl.mem syms.ticache i) then
332: let t = fold syms.dfns (`BTYP_function (typeoflist ts,!ret_type)) in
333: Hashtbl.add syms.ticache i t
334: end
335: ;
336: if syms.compiler_options.print_flag then
337: print_endline ("//bound regmatch " ^ name ^ "<"^si i^">" )
338:
339:
340: | `SYMDEF_reglex (ps,le,cls) ->
341: let bps = bindps ps in
342: let ts = map (fun (s,(i,t)) -> t) (fst bps) in
343: let ret_type = ref (snd (be (snd (hd cls)))) in
344: let bregex = bind_regex syms env sr be ret_type cls in
345: let bbdcl = `BBDCL_reglex ([],bvs,bps,le,!ret_type,bregex) in
346: Hashtbl.add bbdfns i (name,true_parent,sr,bbdcl)
347: ;
348: begin
349: if not (Hashtbl.mem syms.ticache i) then
350: let t = fold syms.dfns (`BTYP_function (typeoflist ts,!ret_type)) in
351: Hashtbl.add syms.ticache i t
352: end
353: ;
354: if syms.compiler_options.print_flag then
355: print_endline ("//bound reglex " ^ name ^ "<"^si i^">" )
356:
357: | `SYMDEF_glr (t,(p,exes)) ->
358: (*
359: print_endline ("Binding nonterm " ^ name ^"<"^ si i ^">");
360: *)
361: let brt = if t = `TYP_none then `BTYP_var (i,`BTYP_type) else bt t in
362: (*
363: print_endline ("Specified type " ^ sbt syms.dfns brt);
364: *)
365: (*
366: let brt = `BTYP_var i in (* hack .. *)
367: *)
368:
369: let bn q =
370: (* we have to check this .. *)
371: match luqn2 q with
372: | FunctionEntry [i],[] ->
373: begin match Hashtbl.find syms.dfns i with
374: | {symdef=`SYMDEF_glr _ } -> `Nonterm [i]
375: | {symdef=`SYMDEF_nonconst_ctor _} -> `Term i
376: | _ -> clierr sr "Expected nonterminal or union constructor"
377: end
378: | FunctionEntry ii,[] ->
379: let i = hd ii in
380: begin match Hashtbl.find syms.dfns i with
381: | {symdef=`SYMDEF_glr _ } -> `Nonterm ii
382: | {symdef=`SYMDEF_nonconst_ctor _} ->
383: clierr sr "Expected unique union constructor (it's overloaded)"
384: | _ -> clierr sr "Expected nonterminal or union constructor"
385: end
386: | NonFunctionEntry i,[] -> `Term i
387: | _,ts -> clierr sr "Unexpected type variables"
388: in
389: let bp p = map (fun (n,q) -> n,bn q) p in
390: let p = bp p in
391: let brt',bbexes = bexes env exes brt i bvs in
392: let bbdcl = `BBDCL_glr ([],bvs,brt',(p, bbexes)) in
393: Hashtbl.add bbdfns i (name,true_parent,sr,bbdcl);
394:
395: if syms.compiler_options.print_flag then
396: print_endline ("//bound glr " ^ name ^ "<"^si i^">" )
397:
398: | `SYMDEF_const_ctor (uidx,ut,ctor_idx) ->
399: let unit_sum =
400: match Hashtbl.find syms.dfns uidx with
401: | {symdef=`SYMDEF_union its} ->
402: fold_left
403: (fun v (_,_,t) ->
404: v && (match t with `AST_void _ -> true | _ -> false)
405: )
406: true
407: its
408: | _ -> assert false
409: in
410: let t = typeofindex syms i in
411: let ut = bt ut in
412: let ct =
413: if unit_sum then si ctor_idx
414: else "_uctor_(" ^ si ctor_idx ^ ",0)"
415: in
416: Hashtbl.add bbdfns i (name,None,sr,`BBDCL_const (bvs,t,`Str ct,[]));
417:
418: if syms.compiler_options.print_flag then
419: print_endline ("//bound const " ^ name ^ "<"^si i^">:" ^
420: sbt syms.dfns t)
421:
422: | `SYMDEF_nonconst_ctor (uidx,ut,ctor_idx,argt) ->
423: let t = typeofindex syms i in
424: let argt = bt argt in
425: let ut = bt ut in
426: let bbdcl = `BBDCL_nonconst_ctor (bvs,uidx,ut,ctor_idx,argt) in
427: Hashtbl.add bbdfns i (name,true_parent,sr,bbdcl);
428:
429: if syms.compiler_options.print_flag then
430: print_endline ("//bound fun " ^ name ^ "<"^si i^">:" ^
431: sbt syms.dfns t)
432:
433: | `SYMDEF_val (t) ->
434: let t = typeofindex syms i in
435: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_val (bvs,t));
436:
437: if syms.compiler_options.print_flag then
438: print_endline ("//bound val " ^ name ^ "<"^si i^">" ^
439: print_bvs bvs ^ ":" ^
440: sbt syms.dfns t)
441:
442: | `SYMDEF_lazy (rt,e) ->
443: let ps = [("dummy",`AST_void sr)],None in
444: let exes = [sr,`EXE_fun_return e] in
445: let brt = bt rt in
446: let brt',bbexes = bexes env exes brt i bvs in
447: let props = [] in
448: let bbdcl =
449: `BBDCL_function (props,bvs,([],None),brt',bbexes)
450: in
451: Hashtbl.add bbdfns i (name,true_parent,sr,bbdcl);
452: begin
453: if not (Hashtbl.mem syms.ticache i) then
454: (* HACK! *)
455: Hashtbl.add syms.ticache i brt'
456: end
457: ;
458: if syms.compiler_options.print_flag then
459: print_endline ("//bound lazy " ^ name ^ "<"^si i^">" ^
460: print_bvs bvs ^ ":" ^
461: sbt syms.dfns brt')
462:
463: | `SYMDEF_var (t) ->
464: (*
465: print_endline ("Binding variable " ^ name ^"<"^ si i ^">");
466: *)
467: let t = typeofindex syms i in
468: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_var (bvs, t))
469: ;
470: if syms.compiler_options.print_flag then
471: print_endline ("//bound var " ^ name ^ "<"^si i^">" ^
472: print_bvs bvs ^ ":" ^
473: sbt syms.dfns t)
474:
475: | `SYMDEF_const (t,ct,reqs) ->
476: let t = typeofindex syms i in
477: let reqs = bind_reqs reqs in
478: Hashtbl.add bbdfns i (name,None,sr,`BBDCL_const (bvs,t,ct,reqs));
479: if syms.compiler_options.print_flag then
480: print_endline ("//bound const " ^ name ^ "<"^si i^">:" ^
481: sbt syms.dfns t)
482:
483:
484: | `SYMDEF_fun (props,ts,ret,ct,reqs,prec) ->
485: let ts = map bt ts in
486: let bret = bt ret in
487: let reqs = bind_reqs reqs in
488: let bbdcl = match bret with
489: | `BTYP_void ->
490: `BBDCL_proc (props,bvs,ts,ct,reqs)
491: | _ ->
492: `BBDCL_fun (props,bvs,ts,bret,ct,reqs,prec)
493: in
494: Hashtbl.add bbdfns i (name,None,sr,bbdcl);
495: begin
496: if not (Hashtbl.mem syms.ticache i) then
497: let t = fold syms.dfns (`BTYP_function (typeoflist ts,bret)) in
498: Hashtbl.add syms.ticache i t
499: end
500: ;
501: let atyp = typeoflist ts in
502: if syms.compiler_options.print_flag then
503: print_endline ("//bound fun " ^ name ^ "<"^si i^">"^
504: print_bvs bvs ^ ":" ^
505: sbt syms.dfns (`BTYP_function (atyp,bret)))
506:
507: | `SYMDEF_callback (props,ts_orig,ret,reqs) ->
508:
509: let bret = bt ret in
510:
511: (* The type of the raw C function's arguments,
512: using address = void* for the callback.
513: This is the one passed to C, and the one we generate
514: to cast the address to a Felix type and then execute it.
515:
516: Note the hack .. binding to C_hack::address .. it isn't
517: necessary because we know it's a void*, but there is no
518: builtin symbol for that.
519:
520: This is the function the user must call to actually
521: invoke the Felix callback passed to it.
522:
523: A callback is much like an exported function,
524: in that it binds a function to some arguments
525: from a C call, however it is passed a closure,
526: whereas exported functions create their own.
527:
528: This function isn't type safe to call at the C
529: level, but it has the correct type to PASS to
530: the usual establishing functions (or pointer to
531: function in a struct)
532:
533: this is an extern "C" function with the original
534: name. The name isn't mangled, and so shouldn't
535: conflict with the typesafe ts_cf below.
536: *)
537: let client_data_pos = ref (-1) in
538: let ts_c =
539: let counter = ref 0 in
540: map
541: (function
542: | `AST_name (_,id,[]) when id = name ->
543: if !client_data_pos = -1 then
544: client_data_pos := !counter
545: ;
546: let address = `AST_name(sr,"address",[]) in
547: bt address
548: | t -> incr counter; bt t
549: )
550: ts_orig
551: in
552:
553: (* The type of the arguments of the Felix callback function,
554: which are the same as the C function, but with the client
555: data pointer dropped
556: *)
557: let ts_f =
558: map bt
559: (
560: filter
561: (function
562: | `AST_name (_,id,[]) when id = name -> false
563: | t -> true
564: )
565: ts_orig
566: )
567: in
568: let tf_args = match ts_f with
569: | [x] -> x
570: | lst -> `BTYP_tuple lst
571: in
572: let tf = `BTYP_function (tf_args, bret) in
573:
574: (* The type of the arguments Felix thinks the raw
575: C function has on a call. A closure of this
576: function is a Felix function .. NOT the raw
577: C function.
578: *)
579: let ts_cf =
580: map
581: (function
582: | `AST_name (_,id,[]) when id = name -> tf
583: | t -> bt t
584: )
585: ts_orig
586: in
587:
588: let prec = "postfix" in
589: let reqs = bind_reqs reqs in
590:
591: let bbdcl = `BBDCL_callback (props,bvs,ts_cf,ts_c,!client_data_pos,bret,reqs,prec) in
592: Hashtbl.add bbdfns i (name,None,sr,bbdcl);
593: begin
594: if not (Hashtbl.mem syms.ticache i) then
595: let t = fold syms.dfns (`BTYP_cfunction (typeoflist ts_cf,bret)) in
596: Hashtbl.add syms.ticache i t
597: end
598: ;
599: let atyp = typeoflist ts_cf in
600: if syms.compiler_options.print_flag then
601: print_endline ("//bound callback fun " ^ name ^ "<"^si i^">"^
602: print_bvs bvs ^ ":" ^
603: sbt syms.dfns (`BTYP_function (atyp,bret)))
604:
605: | `SYMDEF_union (cs) ->
606: (* print_endline ("//Binding union " ^ si i ^ " --> " ^ name);
607: *)
608: let cs' = List.map (fun (n,v,t) -> n, v,bt t) cs in
609: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_union (bvs,cs'))
610:
611: | `SYMDEF_struct (cs) ->
612: (* print_endline ("//Binding struct " ^ si i ^ " --> " ^ name);
613: *)
614: let cs' = List.map (fun (n,t) -> n, bt t) cs in
615: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_struct (bvs,cs'))
616:
617: | `SYMDEF_cstruct (cs) ->
618: (* print_endline ("//Binding cstruct " ^ si i ^ " --> " ^ name);
619: *)
620: let cs' = List.map (fun (n,t) -> n, bt t) cs in
621: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_cstruct (bvs,cs'))
622:
623: | `SYMDEF_cclass (cs) ->
624: (* NOTE: At present the code spec is already handled by symtab,
625: so there is point propagating it .. the bound members are kept
626: to ensure we generate all required types, they don't generate
627: any actual code
628: *)
629:
630: (*
631: (* DUMMY type variable index here!! FIX ME !!!! *)
632: let vs2bvs (s,_) = let i = 0 in s,i in
633: let cs' =
634: List.map (function
635: | `MemberVal (n,t,_) -> `BMemberVal (n, bt t)
636: | `MemberVar (n,t,_) -> `BMemberVar (n, bt t)
637: | `MemberFun (n,vs,t,_) -> `BMemberFun (n, map vs2bvs vs, bt t)
638: | `MemberProc (n,vs,t,_) -> `BMemberProc (n, map vs2bvs vs, bt t)
639: | `MemberCtor (n,t,_) -> `BMemberCtor (n, bt t)
640: )
641: cs
642: in
643: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_cclass (bvs,cs'))
644: *)
645:
646: (* temporary hack, elide interface .. *)
647: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_cclass (bvs,[]))
648:
649: | `SYMDEF_class ->
650: Hashtbl.add bbdfns i (name,true_parent,sr,`BBDCL_class ([],bvs))
651:
652: | `SYMDEF_typeclass _ -> ()
653:
654: | `SYMDEF_regdef _ -> ()
655: | `SYMDEF_type_alias _ -> ()
656: | `SYMDEF_inherit _ -> ()
657: | `SYMDEF_inherit_fun _ -> ()
658:
659: | `SYMDEF_abs (quals,ct,reqs)->
660: (*
661: print_endline ("//Binding abstract type " ^ si i ^ " --> " ^ name);
662: *)
663: let reqs = bind_reqs reqs in
664: let bquals = bind_quals quals in
665: Hashtbl.add bbdfns i (name,None,sr,`BBDCL_abs (bvs,bquals,ct,reqs))
666:
667: | `SYMDEF_insert (ct,ikind,reqs) ->
668: (* print_endline ("//Binding header string " ^ si i ^ " --> " ^ name);
669: *)
670: let reqs = bind_reqs reqs in
671: Hashtbl.add bbdfns i (name,None,sr,`BBDCL_insert (bvs,ct,ikind,reqs))
672:
673: end
674: (*
675: ;
676: print_endline ("BINDING " ^ name ^ "<" ^ si i ^ "> COMPLETE");
677: flush stdout
678: *)
679:
680: let bbind_index syms bbdfns i =
681: if Hashtbl.mem bbdfns i then ()
682: else let entry = Hashtbl.find syms.dfns i in
683: bbind_sym syms bbdfns i entry
684:
685: let cal_children syms bbdfns =
686: let child_map = Hashtbl.create 97 in
687: Hashtbl.iter
688: (fun i (id,parent,sr,entry) ->
689: match parent with
690: | Some parent ->
691: Hashtbl.replace child_map parent
692: (i ::
693: (
694: try Hashtbl.find child_map parent
695: with Not_found -> []
696: )
697: )
698: | None -> ()
699: )
700: bbdfns
701: ;
702: child_map
703:
704: let bbind syms =
705: let bbdfns = Hashtbl.create 97 in
706: (* loop through all counter values [HACK]
707: to get the indices in sequence, AND,
708: to ensure any instantiations will be bound,
709: (since they're always using the current value
710: of syms.counter for an index
711: *)
712: let i = ref 0 in
713: while !i < !(syms.counter) do
714: begin
715: let entry =
716: try Some (Hashtbl.find syms.dfns !i)
717: with Not_found -> None
718: in match entry with
719: | Some entry ->
720: begin try
721: (*
722: begin
723: try match Hashtbl.find syms.dfns !i with {id=id} ->
724: print_endline (" Trying to bind "^id^" index " ^ si !i)
725: with Not_found ->
726: failwith ("Binding error UNKNOWN SYMBOL, index " ^ si !i)
727: end
728: ;
729: *)
730: bbind_sym syms bbdfns !i entry
731: with Not_found ->
732: try match Hashtbl.find syms.dfns !i with {id=id} ->
733: failwith ("Binding error "^id^" index " ^ si !i)
734: with Not_found ->
735: failwith ("Binding error UNKNOWN SYMBOL, index " ^ si !i)
736: end
737: | None -> ()
738: end
739: ;
740: incr i
741: done
742: ;
743: bbdfns
744:
745: let bind_ifaces syms
746: (ifaces:
747: (range_srcref * iface_t * int option) list
748: )
749: =
750: let luqn env n = lookup_qn_in_env syms env n in
751: let bound_ifaces =
752: List.map
753: (function
754: | sr,`IFACE_export_fun (sn, cpp_name), parent ->
755: let env = build_env syms parent in
756: let index,ts = lookup_sn_in_env syms env sn in
757: if length ts = 0 then
758: `BIFACE_export_fun (sr,index, cpp_name)
759: else clierr sr
760: (
761: "Can't export generic entity " ^
762: string_of_suffixed_name sn
763: )
764:
765: | sr,`IFACE_export_type (typ, cpp_name), parent ->
766: let env = build_env syms parent in
767: let t = bind_type syms env dummy_sr typ in
768: if var_occurs t then
769: clierr sr
770: (
771: "Can't export generic type " ^
772: string_of_btypecode syms.dfns t
773: )
774: else
775: `BIFACE_export_type (sr, t, cpp_name)
776: )
777: ifaces
778: in bound_ifaces
779:
780: