5.40. Name Binding

Name binding pass 2.
Start ocaml section to src/flx_bbind.mli[1 /1 ]
     1: # 6 "./lpsrc/flx_bbind.ipk"
     2: open Flx_types
     3: open Flx_ast
     4: open Flx_mtypes2
     5: 
     6: 
     7: val bbind:
     8:   sym_state_t ->
     9:   fully_bound_symbol_table_t
    10: 
    11: val bind_ifaces:
    12:   sym_state_t ->
    13:   (range_srcref * iface_t * int option) list ->
    14:   biface_t list
    15: 
    16: val cal_children:
    17:   sym_state_t ->
    18:   fully_bound_symbol_table_t ->
    19:   (bid_t, bid_t list) Hashtbl.t
    20: 
    21: 
End ocaml section to src/flx_bbind.mli[1]
Start ocaml section to src/flx_bbind.ml[1 /1 ]
     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: 
End ocaml section to src/flx_bbind.ml[1]
Start ocaml section to src/flxb.ml[1 /1 ]
     1: # 809 "./lpsrc/flx_bbind.ipk"
     2: open Flx_util
     3: open Flx_desugar
     4: open Flx_bbind
     5: open Flx_print
     6: open Flx_types
     7: open Flx_symtab
     8: open Flx_getopt
     9: open Flx_version
    10: open Flx_flxopt
    11: open Flx_exceptions
    12: open Flx_mtypes1
    13: open Flx_mtypes2
    14: open Flx_use
    15: ;;
    16: 
    17: let print_help () = print_options(); exit(0)
    18: ;;
    19: let reverse_return_parity = ref false
    20: ;;
    21: 
    22: try
    23:   let argc = Array.length Sys.argv in
    24:   if argc <= 1
    25:   then begin
    26:     print_endline "usage: flxg --key=value ... filename; -h for help";
    27:     raise (Exit 0)
    28:   end
    29:   ;
    30:   let raw_options = parse_options Sys.argv in
    31:   let compiler_options = get_felix_options raw_options in
    32:   reverse_return_parity :=  compiler_options.reverse_return_parity
    33:   ;
    34:   let syms = make_syms compiler_options in
    35: 
    36:   if check_keys raw_options ["h"; "help"]
    37:   then print_help ()
    38:   ;
    39:   if check_key raw_options "version"
    40:   then (print_endline ("Felix Version " ^ !version_data.version_string))
    41:   ;
    42:   if compiler_options.print_flag then begin
    43:     print_string "//Include directories = ";
    44:     List.iter (fun d -> print_string (d ^ " "))
    45:     compiler_options.include_dirs;
    46:     print_endline ""
    47:   end
    48:   ;
    49: 
    50:   let filename =
    51:     match get_key_value raw_options "" with
    52:     | Some s -> s
    53:     | None -> exit 0
    54:   in
    55:   let filebase = filename in
    56:   let input_file_name = filebase ^ ".flx"
    57:   and iface_file_name = filebase ^ ".fix"
    58:   and module_name =
    59:     let n = String.length filebase in
    60:     let i = ref (n-1) in
    61:     while !i <> -1 && filebase.[!i] <> '/' do decr i done;
    62:     String.sub filebase (!i+1) (n - !i - 1)
    63:   in
    64: 
    65:   (* PARSE THE IMPLEMENTATION FILE *)
    66:   print_endline ("//Parsing Implementation " ^ input_file_name);
    67:   let hash_include_files,parse_tree =
    68:     Flx_parse_ctrl.parse_file
    69:       input_file_name
    70:       (Filename.dirname input_file_name)
    71:       compiler_options.include_dirs
    72:       Flx_macro.expand_expression
    73:   in
    74:   let have_interface = Sys.file_exists iface_file_name in
    75:   print_endline (Flx_print.string_of_compilation_unit parse_tree);
    76:   print_endline "//PARSE OK";
    77: 
    78:   let include_dirs =  (* (Filename.dirname input_file_name) :: *) compiler_options.include_dirs in
    79:   let compiler_options = { compiler_options with include_dirs = include_dirs } in
    80:   let syms = { syms with compiler_options = compiler_options } in
    81:   let deblocked = desugar_program syms module_name parse_tree in
    82: 
    83:   let root = !(syms.counter) in
    84:   print_endline ("//Top level module '"^module_name^"' has index " ^ si root);
    85: 
    86:   let table, _, exes, ifaces,dirs =
    87:     build_tables syms "root" 0 None None root false deblocked
    88:   in
    89:     print_endline "//BINDING EXECUTABLE CODE";
    90:     print_endline "//-----------------------";
    91:     let bbdfns = bbind syms in
    92:     let child_map = cal_children syms bbdfns in
    93:     let bifaces = bind_ifaces syms ifaces in
    94:     print_endline "//Binding complete";
    95: 
    96:     let root_proc =
    97:       match
    98:         try Hashtbl.find syms.dfns root
    99:         with Not_found ->
   100:           failwith
   101:           (
   102:             "Can't find root module " ^ si root ^
   103:             " in symbol table?"
   104:           )
   105:       with {id=id; sr=sr; parent=parent;vs=vs;pubmap=name_map;symdef=entry} ->
   106:       begin match entry with
   107:         | `SYMDEF_module -> ()
   108:         | _ -> failwith "Expected to find top level module ''"
   109:       end
   110:       ;
   111:       let entry =
   112:         try Hashtbl.find name_map "_init_"
   113:         with Not_found ->
   114:           failwith "Can't find name _init_ in top level module's name map"
   115:       in
   116:       let index = match entry with
   117:         | FunctionEntry [x] -> x
   118:         | FunctionEntry [] -> failwith "Couldn't find '_init_'"
   119:         | FunctionEntry _ -> failwith "Too many top level procedures called '_init_'"
   120:         | NonFunctionEntry _ -> failwith "_init_ found but not procedure"
   121:       in
   122:       if compiler_options.print_flag
   123:       then print_endline ("//root module's init procedure has index " ^ si index);
   124:       index
   125:     in
   126: 
   127:     Hashtbl.iter
   128:     (fun index (name,parent,sr,entry) -> print_endline
   129:       (
   130:         si index ^ " --> " ^
   131:         string_of_bbdcl syms.dfns entry index
   132:       )
   133:     )
   134:     bbdfns
   135: 
   136: with x -> Flx_terminate.terminate !reverse_return_parity x
   137: ;;
   138: 
End ocaml section to src/flxb.ml[1]