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