5.37. Name Lookup

There are some tricky issues with the name binding rules. First, name binding is complicated by the fact we support overloading. This defeats a simple linear binding scheme: instead, we need to bind the type of the argument of the application of a named function.

In addition, felix provides simple first order generics by allowing declared name to be parameterised by types.

There are two names then: simple and indexed. Indexed names must of course refer to declarations with the right number of parameters.

However, a non-indexed name may refer to a non-generic entity, or, refer to a local generic entity, in which case the arguments are just the list of parameter names.

Actually we can further generalise because of nesting. Name binding consists of uniquely identifying every name, and replacing the concrete name with its canonical representation. Each declared name is number in order of writing, and takes type parameters in a single list which is the concatenation of the visible parameters in order of writing, in other words starting with the outermost construction: we can assume all names are parameterised by a list of types, modeling non-generic names as if they had 0 type parameters.

We need to note now how our code is driven. We start with certain non-genertc root functions, and recurse through the call structure. In the root of course, the type arguments used for a name must selves be monomorphic (free of type variables), so the binding itself is monomorphic.

What this all means is that routines like bind_type and bind_expression are always accepting and returning monomorphic data. What all this means is that the indexing scheme never needs any bound type variables: a name denoting a type parameter is always being replaced by a monotype directly, without any need to first go to variables and then instantiate them.

Hmm .. messy .. consider:

val x0 = 1;
module p1[t1] {
  val x1 = x0;
  module p2[t2] {
    va1 x2a = x1 + x2; // x1[t1] + x2[t1,t2]
    va1 x2b = x1 + p2[int]::x2; // x1[t1] + x2[t1,int]

  .. fine .. but the equivalent function structure:

val x0 = 1;
proc p1[t1]() {
  val x1 = x0;
  proc p2[t2]() {
    va1 x2a = x1 + x2; // x1[t1] + x2[t1,t2]
    // explicit indexing here is not allowed
    // for *variables* since
    // we have to refer to a a stack from on
    // the display which has fixed type
    // parameters .. but it IS allowed for
    // enclosed types (since type are static ..)
SUMMARY .. the total number of variables needed to instaniate a name is the length of the list of the concatenation of the type vaiable lists of the entities ancestors including itself. If any indexes are given explicitly, they're always most local, and replace the last so many bindings from context. Note the number of *implicit* variables needed may be less than those given if the name is defined in a parent: in this case we just take first part of the argument list.

With this mechanism a simply list of bound type indices suffices provided when a lookup is done we calculate how many values are needed.

Hmm: this may cause a LOT of pain, if we're looking up generic functions .. since we assumed the lookup could select on the number of arguments .. well, it can, by adjusting as the search deepens .. nice!

Technology: given an index i, find its vs list including that of its parents (string -> int) form.

Start ocaml section to src/flx_lookup.mli[1 /1 ]
     1: # 96 "./lpsrc/flx_lookup.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes2
     5: 
     6: val lookup_name_in_htab:
     7:   name_map_t ->
     8:   string ->
     9:   entry_set_t option
    10: 
    11: val build_env:
    12:   sym_state_t ->
    13:   int option -> (* parent *)
    14:   env_t
    15: 
    16: val lookup_name_in_env :
    17:   sym_state_t ->
    18:   env_t ->
    19:   range_srcref ->
    20:   id_t ->
    21:   entry_set_t
    22: 
    23: val lookup_qn_in_env :
    24:   sym_state_t ->
    25:   env_t ->
    26:   qualified_name_t ->
    27:   entry_kind_t * typecode_t list
    28: 
    29: val lookup_qn_in_env2:
    30:   sym_state_t ->
    31:   env_t ->
    32:   qualified_name_t ->
    33:   entry_set_t * typecode_t list
    34: 
    35: val lookup_sn_in_env :
    36:   sym_state_t ->
    37:   env_t ->
    38:   suffixed_name_t ->
    39:   int * btypecode_t list
    40: 
    41: val lookup_code_in_env:
    42:   sym_state_t ->
    43:   env_t ->
    44:   range_srcref ->
    45:   qualified_name_t ->
    46:   entry_kind_t list * typecode_t list
    47: 
    48: (** This routine takes an unbound type term
    49: and binds it. The term may contain explicit
    50: type variables. If the term denotes a generative
    51: type (abstract, union, or struct) then an instance
    52: is made with type variables for the indices.
    53: 
    54: Note that the result of binding a term with type
    55: variables is not a type function.
    56: *)
    57: 
    58: val bind_type:
    59:   sym_state_t ->
    60:   env_t ->
    61:   range_srcref ->
    62:   typecode_t ->
    63:   btypecode_t
    64: 
    65: val eval_module_expr:
    66:   sym_state_t ->
    67:   env_t ->
    68:   expr_t ->
    69:   module_rep_t
    70: 
    71: val resolve_overload:
    72:   sym_state_t ->
    73:   range_srcref ->
    74:   entry_kind_t list ->
    75:   id_t ->
    76:   btypecode_t list ->
    77:   btypecode_t list ->      (* explicit param/arg bindings *)
    78:   (entry_kind_t * btypecode_t * (int * btypecode_t) list * btypecode_t list) option
    79: 
    80: val bind_expression :
    81:   sym_state_t ->
    82:   env_t ->
    83:   expr_t ->
    84:   tbexpr_t
    85: 
    86: val typeofindex :
    87:   sym_state_t ->
    88:   int ->
    89:   btypecode_t
    90: 
    91: val typeofindex_with_ts:
    92:   sym_state_t ->
    93:   range_srcref ->
    94:   int ->
    95:   btypecode_t list ->
    96:   btypecode_t
    97: 
    98: val typeof_literal:
    99:   sym_state_t ->
   100:   env_t ->
   101:   range_srcref ->
   102:   literal_t ->
   103:   btypecode_t
   104: 
   105: val lookup_qn_with_sig:
   106:   sym_state_t ->
   107:   range_srcref ->
   108:   range_srcref ->
   109:   env_t ->
   110:   qualified_name_t ->
   111:   btypecode_t list ->
   112:   tbexpr_t
   113: 
   114: val bind_regdef:
   115:   sym_state_t ->
   116:   env_t ->
   117:   int list -> (* regexp exclusion list *)
   118:   regexp_t ->
   119:   regexp_t
   120: 
End ocaml section to src/flx_lookup.mli[1]
Start ocaml section to src/flx_lookup.ml[1 /1 ]
     1: # 217 "./lpsrc/flx_lookup.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_print
     6: open Flx_exceptions
     7: open Flx_mtypes1
     8: open Flx_mtypes2
     9: open Flx_typing
    10: open Flx_typing2
    11: open List
    12: open Flx_srcref
    13: open Flx_unify
    14: open Flx_beta
    15: open Flx_generic
    16: open Flx_name
    17: open Flx_overload
    18: open Flx_tpat
    19: 
    20: let unit_t = `BTYP_tuple []
    21: 
    22: let lvalify t = match t with
    23:   | `BTYP_lvalue _ -> t
    24:   | t -> `BTYP_lvalue t
    25: 
    26: exception Found of int
    27: exception Tfound of btypecode_t
    28: 
    29: type kind_t = Parameter | Other
    30: 
    31: let get_data table index : symbol_data_t =
    32:   try Hashtbl.find table index
    33:   with Not_found ->
    34:     failwith ("[Flx_lookup.get_data] No definition of <" ^ string_of_int index ^ ">")
    35: 
    36: let lookup_name_in_htab htab name : entry_set_t option =
    37:   (* print_endline ("Lookup name in htab: " ^ name); *)
    38:   try Some (Hashtbl.find htab name)
    39:   with Not_found -> None
    40: 
    41: let merge_functions
    42:   (opens:entry_set_t list)
    43:   name
    44: : entry_kind_t list =
    45:   fold_left
    46:     (fun init x -> match x with
    47:     | FunctionEntry ls ->
    48:       fold_left
    49:       (fun init x ->
    50:         if mem x init then init else x :: init
    51:       )
    52:       init ls
    53:     | _ -> failwith ("[merge_functions] Expected " ^ name ^ " to be function overload set in all open modules")
    54:     )
    55:   []
    56:   opens
    57: 
    58: let lookup_name_in_table_dirs table dirs sr name : entry_set_t option =
    59:   (*
    60:   print_endline ("Lookup name " ^ name ^ " in table dirs");
    61:   flush stdout;
    62:   *)
    63:   match lookup_name_in_htab table name with
    64:   | Some x as y ->
    65:     (*
    66:     print_endline ("Lookup_name_in_htab found " ^ name);
    67:     *)
    68:     y
    69:   | None ->
    70:   let opens =
    71:     concat
    72:     (
    73:       map
    74:       (fun table ->
    75:         match lookup_name_in_htab table name with
    76:         | Some x -> [x]
    77:         | None -> []
    78:       )
    79:       dirs
    80:     )
    81:   in
    82:   match opens with
    83:   | [x] -> Some x
    84:   | FunctionEntry ls :: rest ->
    85:     Some (FunctionEntry (merge_functions opens name))
    86: 
    87:   | (NonFunctionEntry (i)) as some ::_ ->
    88:     if
    89:       fold_left
    90:         (function t -> function
    91:           | NonFunctionEntry (j) when i = j -> t
    92:           | _ -> false
    93:         )
    94:         true
    95:         opens
    96:     then
    97:       Some some
    98:     else
    99:       clierr sr ("Conflicting values for "^name ^" found in open modules")
   100: 
   101:   | [] -> None
   102: 
   103: 
   104: type recstop = {
   105:   idx_fixlist: int list;
   106:   type_alias_fixlist: (int * int) list;
   107:   as_fixlist: (string * int) list;
   108:   expr_fixlist: (expr_t * int) list;
   109:   depth:int;
   110:   open_excludes : qualified_name_t list
   111: }
   112: 
   113: let rsground= {
   114:   idx_fixlist = [];
   115:   type_alias_fixlist = [];
   116:   as_fixlist = [];
   117:   expr_fixlist = [];
   118:   depth = 0;
   119:   open_excludes = []
   120: }
   121: 
   122: (* this ugly thing merges a list of function entries
   123: some of which might be inherits, into a list of
   124: actual functions
   125: *)
   126: 
   127: let rec trclose syms rs sr fs =
   128:   let inset = ref IntSet.empty in
   129:   let outset = ref IntSet.empty in
   130:   let exclude = ref IntSet.empty in
   131:   let append fs = iter (fun i -> inset := IntSet.add i !inset) fs in
   132: 
   133:   let rec trclosem () =
   134:     if IntSet.is_empty !inset then ()
   135:     else
   136:       (* grab an element *)
   137:       let x = IntSet.choose !inset in
   138:       inset := IntSet.remove x !inset;
   139: 
   140:       (* loop if already handled *)
   141:       if IntSet.mem x !exclude then trclosem ()
   142:       else begin
   143:         (* say we're handling this one *)
   144:         exclude := IntSet.add x !exclude;
   145: 
   146:         match Hashtbl.find syms.dfns x with
   147:         | {parent=parent; sr=sr2; symdef=`SYMDEF_inherit_fun qn} ->
   148:           let env = build_env syms parent in
   149:           begin match fst (lookup_qn_in_env2' syms env rs qn) with
   150:           | NonFunctionEntry _ -> clierr2 sr sr2 "Inherit fun doesn't denote function set"
   151:           | FunctionEntry fs' -> append fs'; trclosem ()
   152:           end
   153: 
   154:         | _ -> outset := IntSet.add x !outset; trclosem ()
   155:       end
   156:   in
   157:   append fs;
   158:   trclosem ();
   159:   let output = ref [] in
   160:   IntSet.iter (fun i -> output := i :: !output) !outset;
   161:   !output
   162: 
   163: and resolve_inherits syms rs sr x =
   164:   match x with
   165:   | NonFunctionEntry z ->
   166:     begin match Hashtbl.find syms.dfns z with
   167:     | {parent=parent; symdef=`SYMDEF_inherit qn} ->
   168:       (*
   169:       print_endline ("Found an inherit symbol qn=" ^ string_of_qualified_name qn);
   170:       *)
   171:       let env = inner_build_env syms rs parent in
   172:       (*
   173:       print_endline "Environment built for lookup ..";
   174:       *)
   175:       fst (lookup_qn_in_env2' syms env rs qn)
   176:     | {sr=sr2; symdef=`SYMDEF_inherit_fun qn} ->
   177:       clierr2 sr sr2
   178:       "NonFunction inherit denotes function"
   179:     | _ -> x
   180:     end
   181:   | FunctionEntry fs -> FunctionEntry (trclose syms rs sr fs)
   182: 
   183: and lookup_name_in_env syms (env:env_t) sr name : entry_set_t =
   184:  inner_lookup_name_in_env syms (env:env_t) rsground sr name
   185: 
   186: and inner_lookup_name_in_env syms (env:env_t) rs sr name : entry_set_t =
   187:   (*
   188:   print_endline ("[lookup_name_in_env] " ^ name);
   189:   *)
   190:   let rec aux env =
   191:     match env with
   192:     | [] -> None
   193:     | (_,_,table,dirs) :: tail ->
   194:       match lookup_name_in_table_dirs table dirs sr name with
   195:       | Some x as y -> y
   196:       | None -> aux tail
   197:   in
   198:     match aux env with
   199:     | Some x ->
   200:       (*
   201:       print_endline "[lookup_name_in_env] Got result, resolve inherits";
   202:       *)
   203:       resolve_inherits syms rs sr x
   204:     | None ->
   205:       clierr sr
   206:       (
   207:         "[lookup_name_in_env]: Name '" ^
   208:         name ^
   209:         "' not found in environment (depth "^
   210:         string_of_int (length env)^ ")"
   211:       )
   212: 
   213: (* This routine looks up a qualified name in the
   214:    environment and returns an entry_set_t:
   215:    can be either non-function or function set
   216: *)
   217: and lookup_qn_in_env2'
   218:   syms
   219:   (env:env_t)
   220:   (rs:recstop)
   221:   (qn: qualified_name_t)
   222:   : entry_set_t * typecode_t list
   223: =
   224:   (*
   225:   print_endline ("[lookup_qn_in_env2] qn=" ^ string_of_qualified_name qn);
   226:   *)
   227:   match qn with
   228:   | `AST_callback (sr,qn) -> clierr sr "[lookup_qn_in_env2] qualified name is callback [not implemented yet]"
   229:   | `AST_void sr -> clierr sr "[lookup_qn_in_env2] qualified name is void"
   230:   | `AST_case_tag (sr,_) -> clierr sr "[lookup_qn_in_env2] Can't lookup a case tag"
   231:   | `AST_typed_case (sr,_,_) -> clierr sr "[lookup_qn_in_env2] Can't lookup a typed case tag"
   232:   | `AST_index (sr,name,_) ->
   233:     print_endline ("[lookup_qn_in_env2] synthetic name " ^ name);
   234:     clierr sr "[lookup_qn_in_env2] Can't lookup a synthetic name"
   235: 
   236:   | `AST_name (sr,name,ts) ->
   237:     (*
   238:     print_endline ("Found simple name " ^ name);
   239:     *)
   240:     inner_lookup_name_in_env syms env rs sr name, ts
   241: 
   242:   | `AST_the (sr,qn) ->
   243:     let es,ts = lookup_qn_in_env2' syms env rs qn in
   244:     begin match es with
   245:     | NonFunctionEntry  _
   246:     | FunctionEntry [_] -> es,ts
   247:     | _ -> clierr sr
   248:       "'the' expression denotes non-singleton function set"
   249:     end
   250: 
   251:   | `AST_lookup (sr,(me,name,ts)) ->
   252:     (*
   253:     print_endline ("Searching for name " ^ name);
   254:     *)
   255:     match eval_module_expr syms env me with
   256:     | Simple_module (impl,ts', htab,dirs) ->
   257:       let env' = mk_bare_env syms impl in
   258:       let tables = get_pub_tables syms env' rs dirs in
   259:       let result = lookup_name_in_table_dirs htab tables sr name in
   260:       match result with
   261:       | Some entry ->
   262:         resolve_inherits syms rs sr entry,
   263:         ts' @ ts
   264:       | None ->
   265:         clierr sr
   266:         (
   267:           "[lookup_qn_in_env2] Can't find " ^ name
   268:         )
   269: 
   270:       (*
   271:       begin
   272:       try
   273:         let entry = Hashtbl.find htab name in
   274:         resolve_inherits syms rs sr entry,
   275:         ts' @ ts
   276:       with Not_found ->
   277:         clierr sr
   278:         (
   279:           "[lookup_qn_in_env2] Can't find " ^ name
   280:         )
   281:       end
   282:       *)
   283: 
   284: and lookup_qn_in_env2
   285:   syms
   286:   (env:env_t)
   287:   (qn: qualified_name_t)
   288:   : entry_set_t * typecode_t list
   289: =
   290:   lookup_qn_in_env2' syms env rsground qn
   291: 
   292: 
   293: (* this one isn't recursive i hope .. *)
   294: and lookup_code_in_env syms env sr qn =
   295:   let result =
   296:     try Some (lookup_qn_in_env2' syms env rsground qn)
   297:     with _ -> None
   298:   in match result with
   299:   | Some (NonFunctionEntry x,ts) ->
   300:     clierr sr
   301:     (
   302:       "[lookup_qn_in_env] Not expecting " ^
   303:       string_of_qualified_name qn ^
   304:       " to be non-function (code insertions use function entries) "
   305:     )
   306: 
   307:   | Some (FunctionEntry x,ts) ->
   308:     iter
   309:     (fun i ->
   310:       match Hashtbl.find syms.dfns i with
   311:       | {symdef=`SYMDEF_insert _} -> ()
   312:       | {id=id; vs=vs; symdef=y} -> clierr sr
   313:         (
   314:           "Expected requirement '"^
   315:           string_of_qualified_name qn ^
   316:           "' to bind to a header or body insertion, instead got:\n" ^
   317:           string_of_symdef y id vs
   318:         )
   319:     )
   320:     x
   321:     ;
   322:     x,ts
   323: 
   324:   | None -> [0],[]
   325: 
   326: and lookup_qn_in_env
   327:   syms
   328:   (env:env_t)
   329:   (qn: qualified_name_t)
   330:   : entry_kind_t  * typecode_t list
   331: =
   332:   lookup_qn_in_env' syms env rsground qn
   333: 
   334: and lookup_qn_in_env'
   335:   syms
   336:   (env:env_t) rs
   337:   (qn: qualified_name_t)
   338:   : entry_kind_t  * typecode_t list
   339: =
   340:   match lookup_qn_in_env2' syms env rs qn with
   341:     | NonFunctionEntry x,ts -> x,ts
   342:     | FunctionEntry _,_ ->
   343:       let sr = src_of_expr (qn:>expr_t) in
   344:       clierr sr
   345:       (
   346:         "[lookup_qn_in_env] Not expecting " ^
   347:         string_of_qualified_name qn ^
   348:         " to be function set"
   349:       )
   350: 
   351: and lookup_uniq_in_env
   352:   syms
   353:   (env:env_t)
   354:   (qn: qualified_name_t)
   355:   : entry_kind_t  * typecode_t list
   356: =
   357:   match lookup_qn_in_env2' syms env rsground qn with
   358:     | NonFunctionEntry x,ts -> x,ts
   359:     | FunctionEntry [x],ts -> x,ts
   360:     | _ ->
   361:       let sr = src_of_expr (qn:>expr_t) in
   362:       clierr sr
   363:       (
   364:         "[lookup_qn_in_env] Not expecting " ^
   365:         string_of_qualified_name qn ^
   366:         " to be non-singleton function set"
   367:       )
   368: 
   369: and lookup_function_in_env
   370:   syms
   371:   (env:env_t)
   372:   (qn: qualified_name_t)
   373:   : entry_kind_t  * typecode_t list
   374: =
   375:   match lookup_qn_in_env2' syms env rsground qn with
   376:     | FunctionEntry [x],ts -> x,ts
   377:     | _ ->
   378:       let sr = src_of_expr (qn:>expr_t) in
   379:       clierr sr
   380:       (
   381:         "[lookup_qn_in_env] Not expecting " ^
   382:         string_of_qualified_name qn ^
   383:         " to be non-function or non-singleton function set"
   384:       )
   385: 
   386: and lookup_sn_in_env
   387:   syms
   388:   (env:env_t)
   389:   (sn: suffixed_name_t)
   390:   : int * btypecode_t list
   391: =
   392:   let sr = src_of_expr (sn:>expr_t) in
   393:   let bt t = bind_type syms env sr t in
   394:   match sn with
   395:   | #qualified_name_t as x ->
   396:     begin match
   397:       lookup_qn_in_env syms env x
   398:     with
   399:     | index,ts -> index,map bt ts
   400:     end
   401: 
   402:   | `AST_suffix (sr,(qn,suf)) ->
   403:     let bsuf = bind_type syms env sr suf in
   404:     (* OUCH HACKERY *)
   405:     let (be,t) =
   406:       lookup_qn_with_sig'
   407:       syms
   408:       sr sr
   409:       env rsground
   410:       qn [bsuf]
   411:     in match be with
   412:     | `BEXPR_name (index,ts) ->
   413:       index,ts
   414:     | `BEXPR_closure (index,ts) -> index,ts
   415: 
   416:     | _ -> failwith "Expected expression to be index"
   417: 
   418: (* This routine binds a type expression to a bound type expression.
   419:    Note in particular that a type alias is replaced by what
   420:    it as an alias for, recursively so that the result
   421:    globally unique
   422: 
   423:    if params is present it is a list mapping strings to types
   424:    possibly bound type variable
   425: 
   426:    THIS IS WEIRD .. expr_fixlist is propagated, but 'depth'
   427:    isn't. But the depth is essential to insert the correct
   428:    fixpoint term .. ????
   429: 
   430:    i think this arises from:
   431: 
   432:    val x = e1 + y;
   433:    val y = e2 + x;
   434: 
   435:    here, the implied typeof() operator is used
   436:    twice: the first bind expression invoking a second
   437:    bind expression which would invoke the first again ..
   438:    here we have to propagate the bind_expression
   439:    back to the original call on the first term,
   440:    but we don't want to accumulate depths? Hmmm...
   441:    I should test that ..
   442: 
   443: *)
   444: and bind_type syms env sr t : btypecode_t =
   445:   (*
   446:   print_endline ("[bind_type] " ^ string_of_typecode t);
   447:   *)
   448:   let bt:btypecode_t =
   449:     try
   450:       bind_type' syms env rsground sr t []
   451: 
   452:     with
   453:       | Free_fixpoint b ->
   454:         clierr sr
   455:         ("Unresolvable recursive type " ^ sbt syms.dfns b)
   456:   in
   457:   (*
   458:   print_endline ("Bound type= " ^ sbt syms.dfns t);
   459:   *)
   460:   let bt = beta_reduce syms [] bt
   461:   in
   462:     (*
   463:     print_endline ("Beta reduced type= " ^ sbt syms.dfns bt);
   464:     *)
   465:     bt
   466: 
   467: and bind_expression syms env e  =
   468:   let e',t' =
   469:     try
   470:       bind_expression' syms env rsground e []
   471:     with
   472:      | Free_fixpoint b ->
   473:        let sr = src_of_expr e in
   474:        clierr sr
   475:        ("Circular dependency typing expression " ^ string_of_expr e)
   476:   in
   477:   let t' = beta_reduce syms [] t' in
   478:   e',t'
   479: 
   480: 
   481: (* =========================================== *)
   482: (* INTERNAL BINDING ROUTINES *)
   483: (* =========================================== *)
   484: 
   485: (* RECURSION DETECTORS
   486: 
   487: There are FOUR type recursion detectors:
   488: 
   489: idx_fixlist is a list of indexes, used by
   490: bind_index to detect a recursion determining
   491: the type of a function or variable:
   492: the depth is calculated from the list length:
   493: this arises from bind_expression, which uses
   494: bind type : bind_expression is called to deduce
   495: a function return type from returned expressions
   496: 
   497: TEST CASE:
   498:   val x = (x,x) // type is ('a * 'a) as 'a
   499: 
   500: RECURSION CYCLE:
   501:   typeofindex' -> bind_type'
   502: 
   503: type_alias_fixlist is a list of indexes, used by
   504: bind_type_index to detect a recursive type alias,
   505: [list contains depth]
   506: 
   507: TEST CASE:
   508:   typedef a = a * a // type is ('a * 'a) as 'a
   509: 
   510: 
   511: RECURSION CYCLE:
   512:   bind_type' -> type_of_type_index
   513: 
   514: as_fixlist is a list of (name,depth) pairs, used by
   515: bind_type' to detect explicit fixpoint variables
   516: from the TYP_as terms (x as fv)
   517: [list contains depth]
   518: 
   519: TEST CASE:
   520:   typedef a = b * b as b // type is ('a * 'a) as 'a
   521: 
   522: RECURSION CYCLE:
   523:   typeofindex' -> bind_type'
   524: 
   525: expr_fixlist is a list of (expression,depth)
   526: used by bind_type' to detect recursion from
   527: typeof(e) type terms
   528: [list contains depth]
   529: 
   530: TEST CASE:
   531:   val x: typeof(x) = (x,x) // type is ('a * 'a) as 'a
   532: 
   533: RECURSION CYCLE:
   534:   bind_type' -> bind_expression'
   535: 
   536: TRAP NOTES:
   537:   idx_fixlist and expr_fixlist are related :(
   538: 
   539:   The expr_fixlist handles an explicit typeof(expr)
   540:   term, for an arbitrary expr term.
   541: 
   542:   idx_fixlist is initiated by typeofindex, and only
   543:   occurs typing a variable or function from its
   544:   declaration when the declaration is omitted
   545:   OR when cal_ret_type is verifying it
   546: 
   547: BUG: cal_ret_type is used to verify or compute function
   548: return types. However the equivalent for variables
   549: exists, even uninitialised ones. The two cases
   550: should be handled similarly, if not by the same
   551: routine.
   552: 
   553: Note it is NOT a error for a cycle to occur, even
   554: in the (useless) examples:
   555: 
   556:    val x = x;
   557:    var x = x;
   558: 
   559: In the first case, the val simply might not be used.
   560: In the second case, there may be an assignment.
   561: For a function, a recursive call is NOT an error
   562: for the same reason: a function may
   563: contain other calls, or be unused:
   564:   fun f(x:int)= { return if x = 0 then 0 else f (x-1); }
   565: Note two branches, the first determines the return type
   566: as 'int' quite happily.
   567: 
   568: DEPTH:
   569:   Depth is used to determine the argument of the
   570:   fixpoint term.
   571: 
   572:   Depth is incremented when we decode a type
   573:   or expression into subterms.
   574: 
   575: PROPAGATION.
   576: It appears as_fixlist can only occur
   577: binding a type expression, and doesn't propagate
   578: into bind_expression when a typeof() term is
   579: part of the type expression: it's pure a syntactic
   580: feature of a localised type expression.
   581: 
   582:   typedef t = a * typeof(x) as a;
   583:   var x : t;
   584: 
   585: This is NOT the case, for example:
   586: 
   587:   typedef t = a * typeof (f of (a)) as a;
   588: 
   589: shows the as_fixlist label has propagated into
   590: the expression: expressions can contain type
   591: terms. However, the 'as' label IS always
   592: localised to a single term.
   593: 
   594: Clearly, the same thing can happen with a type alias:
   595: 
   596:   typedef a = a * typeof (f of (a));
   597: 
   598: However, type aliases are more general because they
   599: can span statement boundaries:
   600: 
   601:   typedef a = a * typeof (f of (b));
   602:   typedef b = a;
   603: 
   604: Of course, it comes to the same thing after
   605: substitution .. but lookup and binding is responsible
   606: for that. The key distinction is that an as label
   607: is just a string, whereas a type alias name has
   608: an index in the symtab, and a fully qualified name
   609: can be used to look it up: it's identifid by
   610: its index, not a string label: OTOH non-top level
   611: as labels don't map to any index.
   612: 
   613: NASTY CASE: It's possible to have this kind of thing:
   614: 
   615:   typedef a = typeof ( { typedef b = a; return x; } )
   616: 
   617: so that a type_alias CAN indeed be defined inside a type
   618: expression. That alias can't escape however. In fact,
   619: desugaring restructures this with a lambda (or should):
   620: 
   621:   typedef a = typeof (f of ());
   622:   fun f() { typedef b = a; return x; }
   623: 
   624: This should work BUT if an as_label is propagated
   625: we get a failure:
   626: 
   627:   typedef a = typeof ( { typedef c = b; return x; } ) as b;
   628: 
   629: This can be made to work by lifting the as label too,
   630: which means creating a typedef. Hmmm. All as labels
   631: could be replaced by typedefs ..
   632: 
   633: 
   634: MORE NOTES:
   635: Each of these traps is used to inject a fixpoint
   636: term into the expression, ensuring analysis terminates
   637: and recursions are represented in typing.
   638: 
   639: It is sometimes a bit tricky to know when to pass, and when
   640: to reset these detectors: in bind_type' and inner
   641: bind_type of a subterm should usually pass the detectors
   642: with a pushed value in appropriate cases, however and
   643: independent typing, say of an instance index value,
   644: should start with reset traps.
   645: 
   646: *)
   647: 
   648: (*
   649:   we match type patterns by cheating a bit:
   650:   we convert the pattern to a type, replacing
   651:   the _ with a dummy type variable. We then
   652:   record the 'as' terms of the pattern as a list
   653:   of equations with the as variable index
   654:   on the left, and the type term on the right:
   655:   the RHS cannot contain any as variables.
   656: 
   657:   The generated type can contain both,
   658:   but we can factor the as variables out
   659:   and leave the type a function of the non-as
   660:   pattern variables
   661: *)
   662: 
   663: (* params is list of string * bound type *)
   664: 
   665: and bind_type'
   666:   syms env (rs:recstop)
   667:   sr t (params: (string * btypecode_t) list)
   668: : btypecode_t =
   669:   let btp t params = bind_type' syms env
   670:     {rs with depth = rs.depth+1}
   671:     sr t params
   672:   in
   673:   let bt t = btp t params in
   674:   let bi i ts = bind_type_index syms rs sr i ts  in
   675:   let bisub i ts = bind_type_index syms {rs with depth= rs.depth+1} sr i ts in
   676:   (*
   677:   print_endline ("[bind_type'] " ^ string_of_typecode t);
   678:   print_endline ("expr_fixlist is " ^
   679:     catmap ","
   680:     (fun (e,d) -> string_of_expr e ^ " [depth " ^si d^"]")
   681:     expr_fixlist
   682:   );
   683:   if length params <> 0 then
   684:   begin
   685:     print_endline ("  [" ^
   686:     catmap ", "
   687:     (fun (s,t) -> s ^ " -> " ^ sbt syms.dfns t)
   688:     params
   689:     ^ "]"
   690:     )
   691:   end else print_endline  ""
   692:   ;
   693:   *)
   694:   let t =
   695:   match t with
   696:   | `TYP_intersect ts -> `BTYP_intersect (map bt ts)
   697:   | `TYP_record ts -> `BTYP_record (map (fun (s,t) -> s,bt t) ts)
   698:   | `TYP_variant ts -> `BTYP_variant (map (fun (s,t) -> s,bt t) ts)
   699: 
   700:   (* We first attempt to perform the match
   701:     at binding time as an optimisation, if that
   702:     fails, we generate a delayed matching construction.
   703:     The latter will be needed when the argument is a type
   704:     variable.
   705:   *)
   706:   | `TYP_type_match (t,ps) ->
   707:     let t = bt t in
   708:     (*
   709:     print_endline ("Typematch " ^ sbt syms.dfns t);
   710:     *)
   711:     let pts = ref [] in
   712:     let finished = ref false in
   713:     iter
   714:     (fun (p',t') ->
   715:       let p',explicit_vars,any_vars, as_vars, eqns = type_of_tpattern syms p' in
   716:       let p' = bt p' in
   717:       let eqns = map (fun (j,t) -> j, bt t) eqns in
   718:       let varset =
   719:         let x =
   720:           fold_left (fun s (i,_) -> IntSet.add i s)
   721:           IntSet.empty explicit_vars
   722:         in
   723:           fold_left (fun s i -> IntSet.add i s)
   724:           x any_vars
   725:       in
   726:       (* HACK! GACK! we have to assume a variable in a pattern is
   727:         is a TYPE variable .. type patterns don't include coercion
   728:         terms at the moment, so there isn't any way to even
   729:         specify the metatype
   730: 
   731:         In some contexts the kinding can be infered, for example:
   732: 
   733:         int * ?x
   734: 
   735:         clearly x has to be a type .. but a lone type variable
   736:         would require the argument typing to be known ... no
   737:         notation for that yet either
   738:       *)
   739:       let args = map (fun (i,s) ->
   740:       (*
   741:       print_endline ("Mapping " ^ s ^ "<"^si i^"> to TYPE");
   742:       *)
   743:       s,`BTYP_var (i,`BTYP_type)) (explicit_vars @ as_vars)
   744:       in
   745:       let t' = btp t' args in
   746:       let t' = list_subst eqns t' in
   747:       (*
   748:         print_endline ("Bound matching is " ^ sbt syms.dfns p' ^ " => " ^ sbt syms.dfns t');
   749:       *)
   750:       pts := ({pattern=p'; pattern_vars=varset; assignments=eqns},t') :: !pts;
   751:       let u = maybe_unification syms.dfns [p', t] in
   752:       match u with
   753:       | None ->  ()
   754:         (* CRAP! The below argument is correct BUT ..
   755:         our unification algorithm isn't strong enough ...
   756:         so just let this thru and hope it is reduced
   757:         later on instantiation
   758:         *)
   759:         (* If the initially bound, context free pattern can never
   760:         unify with the argument, we have a choice: chuck an error,
   761:         or just eliminate the match case -- I'm going to chuck
   762:         an error for now, because I don't see why one would
   763:         ever code such a case, except as a mistake.
   764:         *)
   765:         (*
   766:         clierr sr
   767:           ("[bind_type'] type match argument\n" ^
   768:           sbt syms.dfns t ^
   769:           "\nwill never unify with pattern\n" ^
   770:           sbt syms.dfns p'
   771:           )
   772:         *)
   773:       | Some mgu ->
   774:         if !finished then
   775:           print_endline "[bind_type] Warning: useless match case ignored"
   776:         else
   777:           let mguvars = fold_left (fun s (i,_) -> IntSet.add i s) IntSet.empty mgu in
   778:           if varset = mguvars then finished := true
   779:     )
   780:     ps
   781:     ;
   782:     let pts = rev !pts in
   783: 
   784:     let tm = `BTYP_type_match (t,pts) in
   785:     (*
   786:     print_endline ("Bound typematch is " ^ sbt syms.dfns tm);
   787:     *)
   788:     tm
   789: 
   790: 
   791:   | `TYP_dual t ->
   792:     let t = bt t in
   793:     dual t
   794: 
   795:   | `TYP_proj (i,t) ->
   796:     let t = bt t in
   797:     ignore (try unfold syms.dfns t with _ -> failwith "TYP_proj unfold screwd");
   798:     begin match unfold syms.dfns t with
   799:     | `BTYP_tuple ls ->
   800:       if i < 1 or i>length ls
   801:       then
   802:        clierr sr
   803:         (
   804:           "product type projection index " ^
   805:           string_of_int i ^
   806:           " out of range 1 to " ^
   807:           string_of_int (length ls)
   808:         )
   809:       else nth ls (i-1)
   810: 
   811:     | _ ->
   812:       clierr sr
   813:       (
   814:         "\ntype projection requires product type"
   815:       )
   816:     end
   817: 
   818:   | `TYP_dom t ->
   819:     let t = bt t in
   820:     begin match unfold syms.dfns t with
   821:     | `BTYP_function (a,b) -> a
   822:     | `BTYP_cfunction (a,b) -> a
   823:     | _ ->
   824:       clierr sr
   825:       (
   826:         short_string_of_src sr ^
   827:         "\ntype domain requires function"
   828:       )
   829:     end
   830:   | `TYP_cod t ->
   831:     let t = bt t in
   832:     begin match unfold syms.dfns t with
   833:     | `BTYP_function (a,b) -> b
   834:     | `BTYP_cfunction (a,b) -> b
   835:     | _ ->
   836:       clierr sr
   837:       (
   838:         short_string_of_src sr ^
   839:         "\ntype codomain requires function"
   840:       )
   841:     end
   842: 
   843:   | `TYP_case_arg (i,t) ->
   844:     let t = bt t in
   845:     ignore (try unfold syms.dfns t with _ -> failwith "TYP_case_arg unfold screwd");
   846:     begin match unfold syms.dfns t with
   847:     | `BTYP_unitsum k ->
   848:       if i < 0 or i >= k
   849:       then
   850:         clierr sr
   851:         (
   852:           "sum type extraction index " ^
   853:           string_of_int i ^
   854:           " out of range 0 to " ^ si (k-1)
   855:         )
   856:       else unit_t
   857: 
   858:     | `BTYP_sum ls ->
   859:       if i < 0 or i>= length ls
   860:       then
   861:         clierr sr
   862:         (
   863:           "sum type extraction index " ^
   864:           string_of_int i ^
   865:           " out of range 0 to " ^
   866:           string_of_int (length ls - 1)
   867:         )
   868:       else nth ls i
   869: 
   870:     | _ ->
   871:       clierr sr
   872:       (
   873:         "sum type extraction requires sum type"
   874:       )
   875:     end
   876: 
   877: 
   878:   | `TYP_ellipsis ->
   879:     failwith "Unexpected `TYP_ellipsis (...) in bind type"
   880:   | `TYP_none ->
   881:     failwith "Unexpected `TYP_none in bind type"
   882: 
   883:   | `TYP_setunion ts -> `BTYP_typesetunion (map bt ts)
   884:   | `TYP_setintersection ts -> `BTYP_typesetintersection (map bt ts)
   885:   | `TYP_typeset ts -> `BTYP_typeset (map bt ts)
   886: 
   887: 
   888:   | `TYP_isin (elt,tset) ->
   889:     let elt = bt elt in
   890:     let tset = bt tset in
   891:     begin match tset with
   892:     (* x isin { a,b,c } is the same as
   893:       typematch x with
   894:       | a => 1
   895:       | b => 1
   896:       | c => 1
   897:       | _ => 0
   898:       endmatch
   899: 
   900:       ** THIS CODE ONLY WORKS FOR BASIC TYPES **
   901: 
   902:       This is because we don't know what to do with any
   903:       type variables in the terms of the set. The problem
   904:       is that 'bind type' just replaces them with bound
   905:       variables. We have to assume they're not pattern
   906:       variables at the moment, therefore they're variables
   907:       from the environment.
   908: 
   909:       We should really allow for patterns, however bound
   910:       patterns aren't just types, but types with binders
   911:       indicating 'as' assignments and pattern variables.
   912: 
   913:       Crudely -- typesets are a hack that we should get
   914:       rid of in the future, since a typematch is just
   915:       more general .. however we have no way to generalise
   916:       type match cases so they can be named at the moment.
   917: 
   918:       This is why we have typesets.. so I need to fix them,
   919:       so the list of things in a typeset is actually
   920:       a sequence of type patterns, not types.
   921: 
   922:     *)
   923:     | `BTYP_typeset ls ->
   924:     let e = IntSet.empty in
   925:     let un = `BTYP_tuple [] in
   926:     let lss = rev_map (fun t -> {pattern=t; pattern_vars=e; assignments=[]},un) ls in
   927:     let fresh = !(syms.counter) in incr (syms.counter);
   928:     let dflt =
   929:       {
   930:         pattern=`BTYP_var (fresh,`BTYP_type);
   931:         pattern_vars = IntSet.singleton fresh;
   932:         assignments=[]
   933:       },
   934:       `BTYP_void
   935:     in
   936:     let lss = rev (dflt :: lss) in
   937:     `BTYP_type_match (elt, lss)
   938: 
   939:     | x ->
   940:       clierr sr
   941:         ("expected explicit typeset, got " ^ sbt syms.dfns x)
   942:     end
   943: 
   944:   (* HACK .. assume variable is type TYPE *)
   945:   | `TYP_var i ->  `BTYP_var (i,`BTYP_type)
   946:   | `TYP_as (t,s) ->
   947:     bind_type' syms env
   948:     { rs with as_fixlist = (s,rs.depth)::rs.as_fixlist }
   949:     sr t params
   950: 
   951:   | `TYP_typeof e ->
   952:     (*
   953:     print_endline ("Evaluating typeof(" ^ string_of_expr e ^ ")");
   954:     *)
   955:     let t =
   956:       if mem_assq e rs.expr_fixlist
   957:       then begin
   958:         (*
   959:         print_endline "Typeof is recursive";
   960:         *)
   961:         let outer_depth = assq e rs.expr_fixlist in
   962:         let fixdepth = outer_depth -rs.depth in
   963:         (*
   964:         print_endline ("OUTER DEPTH IS " ^ string_of_int outer_depth);
   965:         print_endline ("CURRENT DEPTH " ^ string_of_int rs.depth);
   966:         print_endline ("FIXPOINT IS " ^ string_of_int fixdepth);
   967:         *)
   968:         `BTYP_fix fixdepth
   969:       end
   970:       else begin
   971:         snd(bind_expression' syms env rs e [])
   972:       end
   973:     in
   974:       (*
   975:       print_endline ("typeof --> " ^ sbt syms.dfns t);
   976:       *)
   977:       t
   978: 
   979:   | `TYP_array (t1,t2)->
   980:     let index = match bt t2 with
   981:     | `BTYP_tuple [] -> `BTYP_unitsum 1
   982:     | x -> x
   983:     in
   984:     `BTYP_array (bt t1, index)
   985: 
   986:   | `TYP_tuple ts ->
   987:     let ts' =map bt ts  in
   988:     `BTYP_tuple ts'
   989: 
   990:   | `TYP_unitsum k ->
   991:     (match k with
   992:     | 0 -> `BTYP_void
   993:     | 1 -> `BTYP_tuple[]
   994:     | _ -> `BTYP_unitsum k
   995:     )
   996: 
   997:   | `TYP_sum ts ->
   998:     let ts' = map bt ts  in
   999:     if all_units ts' then
  1000:       `BTYP_unitsum (length ts)
  1001:     else
  1002:       `BTYP_sum ts'
  1003: 
  1004:   | `TYP_function (d,c) ->
  1005:     let
  1006:       d' = bt d  and
  1007:       c' = bt c
  1008:     in
  1009:       `BTYP_function (bt d, bt c)
  1010: 
  1011:   | `TYP_cfunction (d,c) ->
  1012:     let
  1013:       d' = bt d  and
  1014:       c' = bt c
  1015:     in
  1016:       `BTYP_cfunction (bt d, bt c)
  1017: 
  1018:   | `TYP_pointer t ->
  1019:      let t' = bt t in
  1020:      `BTYP_pointer t'
  1021: 
  1022:   | `TYP_lvalue t -> lvalify (bt t)
  1023: 
  1024:   | `AST_void _ ->
  1025:     `BTYP_void
  1026: 
  1027:   | `TYP_typefun (ps,r,body) ->
  1028:     (*
  1029:     print_endline ("BINDING TYPE FUNCTION " ^ string_of_typecode t);
  1030:     *)
  1031:     let data =
  1032:       rev_map
  1033:       (fun (name,mt) ->
  1034:         name,
  1035:         bt mt,
  1036:         let n = !(syms.counter) in
  1037:         incr (syms.counter);
  1038:         n
  1039:       )
  1040:       ps
  1041:     in
  1042:     let pnames =  (* reverse order .. *)
  1043:       map (fun (n, t, i) ->
  1044:         (*
  1045:         print_endline ("Binding param " ^ n ^ "<" ^ si i ^ "> metatype " ^ sbt syms.dfns t);
  1046:         *)
  1047:         (n,`BTYP_var (i,t))) data
  1048:     in
  1049:     let bbody =
  1050:       (*
  1051:       print_endline (" ... binding body .. " ^ string_of_typecode body);
  1052:       print_endline ("Context " ^ catmap "" (fun (n,t) -> "\n"^ n ^ " -> " ^ sbt syms.dfns t) (pnames @ params));
  1053:       *)
  1054:       bind_type' syms env { rs with depth=rs.depth+1 }
  1055:       sr
  1056:       body (pnames@params)
  1057:     in
  1058:       let bparams = (* order as written *)
  1059:         rev_map (fun (n,t,i) -> (i,t)) data
  1060:       in
  1061:       (*
  1062:       print_endline "BINDING DONE\n";
  1063:       *)
  1064:       `BTYP_typefun (bparams, bt r, bbody)
  1065: 
  1066:   | `TYP_apply (`AST_name (_,"_flatten",[]),t2) ->
  1067:     let t2 = bt t2 in
  1068:     begin match t2 with
  1069:     | `BTYP_unitsum a -> t2
  1070:     | `BTYP_sum (`BTYP_sum a :: t) -> `BTYP_sum (fold_left (fun acc b ->
  1071:       match b with
  1072:       | `BTYP_sum b -> acc @ b
  1073:       | `BTYP_void -> acc
  1074:       | _ -> clierr sr "Sum of sums required"
  1075:       ) a t)
  1076: 
  1077:     | `BTYP_sum (`BTYP_unitsum a :: t) -> `BTYP_unitsum (fold_left (fun acc b ->
  1078:       match b with
  1079:       | `BTYP_unitsum b -> acc + b
  1080:       | `BTYP_tuple [] -> acc + 1
  1081:       | `BTYP_void -> acc
  1082:       | _ -> clierr sr "Sum of unitsums required"
  1083:       ) a t)
  1084: 
  1085:     | `BTYP_sum (`BTYP_tuple []  :: t) -> `BTYP_unitsum (fold_left (fun acc b ->
  1086:       match b with
  1087:       | `BTYP_unitsum b -> acc + b
  1088:       | `BTYP_tuple [] -> acc + 1
  1089:       | `BTYP_void -> acc
  1090:       | _ -> clierr sr "Sum of unitsums required"
  1091:       ) 1 t)
  1092: 
  1093:     | _ -> clierr sr ("Cannot flatten type " ^ sbt syms.dfns t2)
  1094:     end
  1095: 
  1096:   | `TYP_apply(#qualified_name_t as qn, t2) ->
  1097:      let t2 = bt t2 in
  1098:      (*
  1099:      print_endline ("meta typing argument " ^ sbt syms.dfns t2);
  1100:      *)
  1101:      let sign = metatype syms [] t2 in
  1102:      (*
  1103:      print_endline ("Arg type " ^ sbt syms.dfns t2 ^ " meta type " ^ sbt syms.dfns sign);
  1104:      *)
  1105:      let t =
  1106:        try match qn with
  1107:        | `AST_name (sr,name,[]) ->
  1108:          let t1 = assoc name params in
  1109:          `BTYP_apply(t1,t2)
  1110:        | _ -> raise Not_found
  1111:        with Not_found ->
  1112: 
  1113:        (* Note: parameters etc cannot be found with a qualified name,
  1114:        unless it is a simple name .. which is already handled by
  1115:        the previous case .. so we can drop them .. ?
  1116:        *)
  1117: 
  1118:        let result = lookup_qn_with_sig' syms sr sr env
  1119:          {rs with depth=rs.depth+1 } qn [sign]
  1120:        in
  1121:        (* this is a hack, since result will be a closure expression,
  1122:           we just want a bound name .. but type name lookup, which returns
  1123:           the derired type, doesn't do overloading: so we use lookup_qn_with_sig,
  1124:           and then decode the result to get the index, then just use a numbered name
  1125:        *)
  1126:        (* HUMM .. what if the result is a parameter? then its a
  1127:        variable, already a 'closure' -- meaning analogous to
  1128:        the usual situation!! We have to know if we've found
  1129:        a parameter or a type function.
  1130:        *)
  1131:        (*
  1132:        print_endline ("Result of lookup is " ^ sbe syms.dfns result);
  1133:        *)
  1134:        let j,ts =
  1135:          match result with
  1136:          | `BEXPR_closure(j,ts),mt -> j,ts
  1137:          | _ -> assert false
  1138:        in
  1139:        (*
  1140:        print_endline ("Rebinding index " ^ si j);
  1141:        *)
  1142:        let t1 = bisub j ts in
  1143:        (*
  1144:        print_endline ("Result of binding is term " ^ sbt syms.dfns t1);
  1145:        *)
  1146:        `BTYP_apply (t1,t2)
  1147:      in
  1148:      (*
  1149:      print_endline ("type Application is " ^ sbt syms.dfns t);
  1150:      *)
  1151:      let t = beta_reduce syms [] t in
  1152:      (*
  1153:      print_endline ("after beta reduction is " ^ sbt syms.dfns t);
  1154:      *)
  1155:      t
  1156: 
  1157: 
  1158:   | `TYP_apply (t1,t2) ->
  1159:     let t1 = bt t1 in
  1160:     let t2 = bt t2 in
  1161:     let t = `BTYP_apply (t1,t2) in
  1162:     (*
  1163:     let t = beta_reduce syms [] t in
  1164:     *)
  1165:     t
  1166: 
  1167:   | `TYP_type_tuple ts ->
  1168:     `BTYP_type_tuple (map bt ts)
  1169: 
  1170:   | `TYP_type -> `BTYP_type
  1171: 
  1172:   | `AST_name (sr,s,[]) when mem_assoc s rs.as_fixlist ->
  1173:     `BTYP_fix ((assoc s rs.as_fixlist)-rs.depth)
  1174: 
  1175:   | `AST_name (sr,s,[]) when mem_assoc s params ->
  1176:     (*
  1177:     print_endline "Found in assoc list .. ";
  1178:     *)
  1179:     assoc s params
  1180: 
  1181:   | `TYP_glr_attr_type qn ->
  1182:     (*
  1183:     print_string ("[bind_type] Calculating type of glr symbol " ^ string_of_qualified_name qn);
  1184:     *)
  1185:     (* WARNING: we're skipping the recursion stoppers here !! *)
  1186:     let t =
  1187:       match lookup_qn_in_env2' syms env rs qn with
  1188:       | FunctionEntry ii,[] ->
  1189:         cal_glr_attr_type syms sr ii
  1190: 
  1191:       | NonFunctionEntry i,[] ->
  1192:         begin match Hashtbl.find syms.dfns i with
  1193:         | {sr=sr; symdef=`SYMDEF_const_ctor (_,ut,_)} -> `BTYP_void (* hack *)
  1194:         | {sr=sr; symdef=`SYMDEF_nonconst_ctor (_,_,_,argt)} ->
  1195:           cal_glr_attr_type'' syms sr i argt
  1196:         | _ -> clierr sr "Token must be union constructor"
  1197:         end
  1198:       | _,ts -> clierr sr "GLR symbol can't have type subscripts"
  1199:     in
  1200:       (*
  1201:       print_endline (" .. Calculated: " ^sbt syms.dfns t);
  1202:       *)
  1203:       t
  1204: 
  1205: 
  1206:   | `AST_index (sr,name,index) as x ->
  1207:     (*
  1208:     print_endline ("[bind type] AST_index " ^ string_of_qualified_name x);
  1209:     *)
  1210:     let { vs=vs; symdef=entry } =
  1211:       try Hashtbl.find syms.dfns index
  1212:       with Not_found ->
  1213:         syserr sr ("Synthetic name "^name ^ " not in symbol table!")
  1214:     in
  1215:     begin match entry with
  1216:     | `SYMDEF_struct _
  1217:     | `SYMDEF_cstruct _
  1218:     | `SYMDEF_union _
  1219:     | `SYMDEF_class
  1220:     | `SYMDEF_cclass _
  1221:     | `SYMDEF_abs _
  1222:       ->
  1223:       (* I STILL DO NOT UNDERSTAND THIS .. BUT LOTS OF EXAMPLES USE IT
  1224:          AND IT WORKS .. so the diagnostic is comment out
  1225:       *)
  1226:       (*
  1227:       if length vs <> 0 then begin
  1228:         print_endline ("Synthetic name "^name ^ " is a nominal type!");
  1229:         print_endline ("Using ts = [] .. probably wrong since type is polymorphic!");
  1230:       end
  1231:       ;
  1232:       *)
  1233:       `BTYP_inst (index,[])
  1234: 
  1235:     | `SYMDEF_typevar _ ->
  1236:       print_endline ("Synthetic name "^name ^ " is a typevar!");
  1237:       syserr sr ("Synthetic name "^name ^ " is a typevar!")
  1238: 
  1239:     | _
  1240:       ->
  1241:         print_endline ("Synthetic name "^name ^ " is not a nominal type!");
  1242:         syserr sr ("Synthetic name "^name ^ " is not a nominal type!")
  1243:     end
  1244: 
  1245:   (* QUALIFIED OR UNQUALIFIED NAME *)
  1246:   | #qualified_name_t as x ->
  1247:     (*
  1248:     print_endline ("Matched qualified name " ^ string_of_qualified_name x);
  1249:     *)
  1250:     begin match lookup_qn_in_env syms env x with
  1251:     | i,ts ->
  1252:       let ts = map bt ts in
  1253:       (*
  1254:       print_endline ("Qualified name lookup finds index " ^ si i ^
  1255:       "[" ^ catmap "," (sbt syms.dfns) ts ^ "]");
  1256:       *)
  1257:       bi i ts
  1258:     end
  1259: 
  1260:   | `AST_suffix (sr,(qn,t)) ->
  1261:     let sign = bt t in
  1262:     let result =
  1263:       lookup_qn_with_sig' syms  sr sr env rs qn [sign]
  1264:     in
  1265:     begin match result with
  1266:     | `BEXPR_closure (i,ts),_ ->
  1267:       bi i ts
  1268:     | _  -> clierr sr
  1269:       (
  1270:         "[typecode_of_expr] Type expected, got: " ^
  1271:         sbe syms.dfns result
  1272:       )
  1273:     end
  1274:   in
  1275:     (*
  1276:     print_endline ("Bound type is " ^ sbt syms.dfns t);
  1277:     *)
  1278:     t
  1279: 
  1280: and cal_glr_attr_type'' syms sr i t =
  1281:   try Hashtbl.find syms.glr_cache i
  1282:   with Not_found ->
  1283:   try Hashtbl.find syms.varmap i
  1284:   with Not_found ->
  1285:   match t with
  1286:   | `TYP_none -> `BTYP_var (i,`BTYP_type)
  1287:   | _ ->
  1288:     let env = build_env syms (Some i) in
  1289:     let t = bind_type syms env sr t in
  1290:     Hashtbl.add syms.glr_cache i t;
  1291:     Hashtbl.add syms.varmap i t;
  1292:     t
  1293: 
  1294: and cal_glr_attr_type' syms sr i =
  1295:   match Hashtbl.find syms.dfns i with
  1296:   | {symdef=`SYMDEF_glr (t,_)} ->
  1297:     `Nonterm,cal_glr_attr_type'' syms sr i t
  1298: 
  1299:   | {symdef=`SYMDEF_nonconst_ctor (_,_,_,t)} ->
  1300:     `Term, cal_glr_attr_type'' syms sr i t
  1301: 
  1302:   (* shouldn't happen .. *)
  1303:   | {symdef=`SYMDEF_const_ctor (_,_,_)} ->
  1304:     `Term, `BTYP_void
  1305: 
  1306:   | {id=id;symdef=symdef} ->
  1307:     clierr sr (
  1308:       "[cal_glr_attr_type'] Expected glr nonterminal or token "^
  1309:       "(union constructor with argument), got\n" ^
  1310:       string_of_symdef symdef id []
  1311:     )
  1312: 
  1313: and cal_glr_attr_type syms sr ii =
  1314:   let idof i = match Hashtbl.find syms.dfns i with {id=id} -> id in
  1315:   match ii with
  1316:   | [] -> syserr sr "Unexpected empty FunctonEntry"
  1317:   | h :: tts ->
  1318:     let kind,t = cal_glr_attr_type' syms sr h in
  1319:     iter
  1320:     (fun i ->
  1321:       let kind',t' = cal_glr_attr_type' syms sr i in
  1322:       match kind,kind' with
  1323:       | `Nonterm,`Nonterm
  1324:       | `Term,`Term  ->
  1325:         if not (type_eq syms.dfns t t') then
  1326:         clierr sr
  1327:         ("Expected same type for glr symbols,\n" ^
  1328:           idof h ^ " has type " ^ sbt syms.dfns t ^ "\n" ^
  1329:           idof i ^ " has type " ^ sbt syms.dfns t'
  1330:         )
  1331: 
  1332:       | `Nonterm,`Term -> clierr sr "Expected glr nonterminal argument"
  1333:       | `Term,`Nonterm -> clierr sr "Token: Expected union constructor with argument"
  1334:     )
  1335:     tts
  1336:     ;
  1337:     t
  1338: 
  1339: and bind_type_index syms (rs:recstop)
  1340:   sr index ts
  1341: =
  1342:   (*
  1343:   print_endline
  1344:   (
  1345:     "BINDING INDEX " ^ string_of_int index ^
  1346:     " with ["^
  1347:     catmap ", "
  1348:     (sbt syms.dfns)
  1349:     ts^
  1350:     "]"
  1351:   );
  1352:   print_endline ("type alias fixlist is " ^ catmap ","
  1353:     (fun (i,j) -> si i ^ "(depth "^si j^")") type_alias_fixlist
  1354:   );
  1355:   *)
  1356:   if mem_assoc index rs.type_alias_fixlist
  1357:   then begin
  1358:     (*
  1359:     print_endline (
  1360:       "Making fixpoint for Recursive type alias " ^
  1361:       (
  1362:         match get_data syms.dfns index with {id=id;sr=sr}->
  1363:           id ^ " defined at " ^
  1364:           short_string_of_src sr
  1365:       )
  1366:     );
  1367:     *)
  1368:     `BTYP_fix ((assoc index rs.type_alias_fixlist)-rs.depth)
  1369:   end
  1370:   else begin
  1371:   (*
  1372:   print_endline "bind_type_index";
  1373:   *)
  1374:   let ts = adjust_ts syms sr index ts in
  1375:   let bt t =
  1376:       let params = make_params syms sr index ts in
  1377:       let env:env_t = build_env syms (Some index) in
  1378:       let t =
  1379:         bind_type' syms env
  1380:         { rs with type_alias_fixlist = (index,rs.depth):: rs.type_alias_fixlist }
  1381:         sr t params
  1382:       in
  1383:         (*
  1384:         print_endline ("Unravelled and bound is " ^ sbt syms.dfns t);
  1385:         *)
  1386:         let t = beta_reduce syms [] t in
  1387:         (*
  1388:         print_endline ("Beta reduced: " ^ sbt syms.dfns t);
  1389:         *)
  1390:         t
  1391:   in
  1392:   match get_data syms.dfns index with
  1393:   | {id=id;sr=sr;parent=parent;vs=vs;pubmap=tabl;dirs=dirs;symdef=entry} ->
  1394:     (*
  1395:     if length vs <> length ts
  1396:     then
  1397:       clierr sr
  1398:       (
  1399:         "[bind_type_index] Wrong number of type arguments for " ^ id ^
  1400:         ", expected " ^
  1401:         si (length vs) ^ " got " ^ si (length ts)
  1402:       );
  1403:     *)
  1404:     match entry with
  1405:     | `SYMDEF_typevar mt ->
  1406:       (* HACK! We will assume metatype are entirely algebraic,
  1407:         that is, they cannot be named and referenced, we also
  1408:         assume they cannot be subscripted .. the bt routine
  1409:         that works for type aliases doesn't seem to work for
  1410:         metatypes .. we get vs != ts .. ts don't make sense
  1411:         for type variables, only for named things ..
  1412:       *)
  1413:       let mt = bind_type syms [] sr mt in
  1414:       `BTYP_var (index,mt)
  1415: 
  1416:     (* type alias RECURSE *)
  1417:     | `SYMDEF_type_alias t ->
  1418:       (*
  1419:       print_endline ("Unravelling type alias " ^ id);
  1420:       *)
  1421:       bt t
  1422: 
  1423:     | `SYMDEF_abs _ ->
  1424:       `BTYP_inst (index,ts)
  1425: 
  1426:     | `SYMDEF_union _
  1427:     | `SYMDEF_struct _
  1428:     | `SYMDEF_cstruct _
  1429:     | `SYMDEF_class
  1430:     | `SYMDEF_cclass _
  1431:       ->
  1432:       `BTYP_inst (index,ts)
  1433: 
  1434: 
  1435:     | _ ->
  1436:       clierr sr
  1437:       (
  1438:         "[bind_type_index] Type " ^ id ^
  1439:         " must be a type [alias, abstract, union, struct], got:\n" ^
  1440:         string_of_symdef entry id vs
  1441:       )
  1442:   end
  1443: 
  1444: 
  1445: and base_typename_of_literal v = match v with
  1446:   | `AST_int (t,_) -> t
  1447:   | `AST_float (t,_) -> t
  1448:   | `AST_string _ -> "string"
  1449:   | `AST_cstring _ -> "charp"
  1450:   | `AST_wstring _ -> "wstring"
  1451:   | `AST_ustring _ -> "string"
  1452: 
  1453: and  typeof_literal syms env sr v : btypecode_t =
  1454:   let _,_,root,_ = hd (rev env) in
  1455:   let name = base_typename_of_literal v in
  1456:   let t = `AST_name (sr,name,[]) in
  1457:   let bt = bind_type syms env sr t in
  1458:   bt
  1459: 
  1460: and typeofindex_with_ts
  1461:   syms sr
  1462:   (index:int)
  1463:   ts
  1464: =
  1465:   let t = typeofindex syms index in
  1466:   let varmap = make_varmap syms sr index ts in
  1467:   let t = varmap_subst varmap t in
  1468:   beta_reduce syms [] t
  1469: 
  1470: (* This routine should ONLY 'fail' if the return type
  1471:   is indeterminate. This cannot usually happen.
  1472: 
  1473:   Otherwise, the result may be recursive, possibly
  1474:   Fix 0 -- which is determinate 'indeterminate' value :-)
  1475: 
  1476:   For example: fun f(x:int) { return f x; }
  1477: 
  1478:   should yield fix 0, and NOT fail.
  1479: *)
  1480: 
  1481: 
  1482: (* cal_ret_type uses the private name map *)
  1483: (* args is string,btype list *)
  1484: and cal_ret_type syms (rs:recstop) index args =
  1485:   (*
  1486:   print_endline ("[cal_ret_type] index " ^ si index);
  1487:   print_endline ("expr_fixlist is " ^
  1488:     catmap ","
  1489:     (fun (e,d) -> string_of_expr e ^ " [depth " ^si d^"]")
  1490:     rs.expr_fixlist
  1491:   );
  1492:   *)
  1493:   let env = build_env syms (Some index) in
  1494:   (*
  1495:   print_env_short env;
  1496:   *)
  1497:   match (get_data syms.dfns index) with
  1498:   | {id=id;sr=sr;parent=parent;vs=vs;privmap=name_map;dirs=dirs;
  1499:      symdef=`SYMDEF_function ((ps,_),rt,props,exes)
  1500:     } ->
  1501:     (*
  1502:     print_endline ("Calculate return type of " ^ id);
  1503:     *)
  1504:     let rt = bind_type' syms env rs sr rt args in
  1505:     let rt = beta_reduce syms [] rt in
  1506:     let ret_type = ref rt in
  1507:     (*
  1508:     begin match rt with
  1509:     | `BTYP_var (i,_) when i = index ->
  1510:       print_endline "No return type given"
  1511:     | _ ->
  1512:       print_endline (" .. given type is " ^ sbt syms.dfns rt)
  1513:     end
  1514:     ;
  1515:     *)
  1516:     let return_counter = ref 0 in
  1517:     iter
  1518:     (fun exe -> match exe with
  1519:     | (sr,`EXE_fun_return e) ->
  1520:       incr return_counter;
  1521:       (*
  1522:       print_endline ("  .. Handling return of " ^ string_of_expr e);
  1523:       *)
  1524:       begin try
  1525:         let t =
  1526:           (* this is bad code .. we lose detection
  1527:           of errors other than recursive dependencies ..
  1528:           which shouldn't be errors anyhow ..
  1529:           *)
  1530:             snd
  1531:             (
  1532:               bind_expression' syms env
  1533:               { rs with idx_fixlist = index::rs.idx_fixlist }
  1534:               e []
  1535:             )
  1536:         in
  1537:         if do_unify syms !ret_type t (* the argument order is crucial *)
  1538:         then
  1539:           ret_type := varmap_subst syms.varmap !ret_type
  1540:         else begin
  1541:           (*
  1542:           print_endline
  1543:           (
  1544:             "[cal_ret_type2] Inconsistent return type of " ^ id ^ "<"^string_of_int index^">" ^
  1545:             "\nGot: " ^ sbt syms.dfns !ret_type ^
  1546:             "\nAnd: " ^ sbt syms.dfns t
  1547:           )
  1548:           ;
  1549:           *)
  1550:           clierr sr
  1551:           (
  1552:             "[cal_ret_type2] Inconsistent return type of " ^ id ^ "<"^string_of_int index^">" ^
  1553:             "\nGot: " ^ sbt syms.dfns !ret_type ^
  1554:             "\nAnd: " ^ sbt syms.dfns t
  1555:           )
  1556:         end
  1557:       with
  1558:         | Stack_overflow -> failwith "[cal_ret_type] Stack overflow"
  1559:         | Expr_recursion e -> ()
  1560:         | Free_fixpoint t -> ()
  1561:         | Unresolved_return (sr,s) -> ()
  1562:         | ClientError (sr,s) as e -> raise (ClientError (sr,"Whilst calculating return type:\n"^s))
  1563:         | x ->
  1564:         (*
  1565:         print_endline ("  .. Unable to compute type of " ^ string_of_expr e);
  1566:         print_endline ("Reason: " ^ Printexc.to_string x);
  1567:         *)
  1568:         ()
  1569:       end
  1570:     | _ -> ()
  1571:     )
  1572:     exes
  1573:     ;
  1574:     if !return_counter = 0 then (* it's a procedure .. *)
  1575:     begin
  1576:       let mgu = do_unify syms !ret_type `BTYP_void in
  1577:       ret_type := varmap_subst syms.varmap !ret_type
  1578:     end
  1579:     ;
  1580:     (* not sure if this is needed or not ..
  1581:       if a type variable is computed during evaluation,
  1582:       but the evaluation fails .. substitute now
  1583:     ret_type := varmap_subst syms.varmap !ret_type
  1584:     ;
  1585:     *)
  1586:     (*
  1587:     let ss = ref "" in
  1588:     Hashtbl.iter
  1589:     (fun i t -> ss:=!ss ^si i^ " --> " ^sbt syms.dfns t^ "\n")
  1590:     syms.varmap;
  1591:     print_endline ("syms.varmap=" ^ !ss);
  1592:     print_endline ("  .. ret type index " ^ si index ^ " = " ^ sbt syms.dfns !ret_type);
  1593:     *)
  1594:     !ret_type
  1595: 
  1596:   | _ -> assert false
  1597: 
  1598: 
  1599: and inner_typeofindex_with_ts
  1600:   syms sr (rs:recstop)
  1601:   (index:int)
  1602:   (ts: btypecode_t list)
  1603: : btypecode_t =
  1604:  (*
  1605:  print_endline "Inner type of index with ts ..";
  1606:  *)
  1607:  let t = inner_typeofindex syms rs index in
  1608:  let varmap = make_varmap syms sr index ts in
  1609:  let t = varmap_subst varmap t in
  1610:  beta_reduce syms [] t
  1611: 
  1612: 
  1613: (* this routine is called to find the type of a function
  1614: or variable .. so there's no type_alias_fixlist ..
  1615: *)
  1616: 
  1617: and typeofindex
  1618:   syms
  1619:   (index:int)
  1620: : btypecode_t =
  1621:     (*
  1622:     let () = print_endline ("Top level type of index " ^ si index) in
  1623:     *)
  1624:     if Hashtbl.mem syms.ticache index
  1625:     then begin
  1626:       let t = Hashtbl.find syms.ticache index in
  1627:       (*
  1628:       let () = print_endline ("Cached .." ^ sbt syms.dfns t) in
  1629:       *)
  1630:       t
  1631:     end
  1632:     else
  1633:       let t = inner_typeofindex syms rsground index in
  1634:       let _ = try unfold syms.dfns t with _ ->
  1635:         print_endline "typeofindex produced free fixpoint";
  1636:         failwith "[typeofindex] free fixpoint constructed"
  1637:       in
  1638:       let t = beta_reduce syms [] t in
  1639:       (*
  1640:       print_endline ("Type of index "^ si index ^ " is " ^ sbt syms.dfns t);
  1641:       *)
  1642:       (match t with (* HACK .. *)
  1643:       | `BTYP_fix _ -> ()
  1644:       | _ -> Hashtbl.add syms.ticache index t
  1645:       );
  1646:       t
  1647: 
  1648: and inner_typeofindex
  1649:   syms (rs:recstop)
  1650:   (index:int)
  1651: : btypecode_t =
  1652:   (*
  1653:   print_endline ("[inner_type_of_index] " ^ si index);
  1654:   print_endline ("expr_fixlist is " ^
  1655:     catmap ","
  1656:     (fun (e,d) -> string_of_expr e ^ " [depth " ^si d^"]")
  1657:     rs.expr_fixlist
  1658:   );
  1659:   *)
  1660:   (* check the cache *)
  1661:   try Hashtbl.find syms.ticache index
  1662:   with Not_found ->
  1663: 
  1664:   (* check index recursion *)
  1665:   if mem index rs.idx_fixlist
  1666:   then `BTYP_fix (-rs.depth)
  1667:   else begin
  1668:   match get_data syms.dfns index with
  1669:   | {id=id;sr=sr;parent=parent;vs=vs;privmap=table;dirs=dirs;symdef=entry}
  1670:   ->
  1671:   let env:env_t = build_env syms (Some index) in
  1672:   (*
  1673:   print_endline ("Setting up env for " ^ si index);
  1674:   print_env_short env;
  1675:   *)
  1676:   let bt t:btypecode_t =
  1677:     let t' =
  1678:       bind_type' syms env rs sr t [] in
  1679:     let t' = beta_reduce syms [] t' in
  1680:     t'
  1681:   in
  1682:   match entry with
  1683:   | `SYMDEF_callback _ -> print_endline "Inner type of index finds callback"; assert false
  1684:   | `SYMDEF_inherit qn -> failwith ("Woops inner_typeofindex found inherit " ^ si index)
  1685:   | `SYMDEF_inherit_fun qn -> failwith ("Woops inner_typeofindex found inherit fun!! " ^ si index)
  1686:   | `SYMDEF_type_alias t ->
  1687:     begin
  1688:       let t = bt t in
  1689:       let mt = metatype syms [] t in
  1690:       (*
  1691:       print_endline ("Type of type alias is meta_type: " ^ sbt syms.dfns mt);
  1692:       *)
  1693:       mt
  1694:     end
  1695: 
  1696:   | `SYMDEF_function ((ps,_), rt,_,_) ->
  1697:     let pts = map snd ps in
  1698:     let rt' =
  1699:       try Hashtbl.find syms.varmap index with Not_found ->
  1700:       cal_ret_type syms { rs with idx_fixlist = index::rs.idx_fixlist}
  1701:       index []
  1702:     in
  1703:       (* this really isn't right .. need a better way to
  1704:         handle indeterminate result .. hmm ..
  1705:       *)
  1706:       if var_i_occurs index rt' then
  1707:         raise (Unresolved_return (sr,
  1708:         (
  1709:           "[typeofindex'] " ^
  1710:           "function "^id^"<"^string_of_int index^
  1711:           ">: Can't resolve return type, got : " ^
  1712:           sbt syms.dfns rt' ^
  1713:           "\nPossibly each returned expression depends on the return type" ^
  1714:           "\nTry adding an explicit return type annotation"
  1715:         )))
  1716:       else
  1717:         let t = `BTYP_function (bt (typeof_list pts), rt') in
  1718:         t
  1719: 
  1720:   | `SYMDEF_const (t,_,_)
  1721:   | `SYMDEF_parameter (t)
  1722:   | `SYMDEF_val (t)
  1723:   | `SYMDEF_var (t)
  1724:   | `SYMDEF_const_ctor (_,t,_)
  1725:     ->
  1726:     (*
  1727:     print_endline ("Calculating type of variable " ^ id);
  1728:     *)
  1729:     bt t
  1730: 
  1731:   | `SYMDEF_regmatch (ps,cls)
  1732:   | `SYMDEF_reglex (ps,_,cls) ->
  1733:     let be e =
  1734:       bind_expression' syms env
  1735:       { rs with idx_fixlist = index::rs.idx_fixlist }
  1736:       e []
  1737:     in
  1738:     let t = snd (be (snd (hd cls))) in
  1739:     let lexit_t = bt (`AST_lookup (sr,(`AST_name (sr,"Lexer",[]),"iterator",[]))) in
  1740:     `BTYP_function (`BTYP_array (lexit_t,`BTYP_unitsum 2),t)
  1741: 
  1742:   | `SYMDEF_nonconst_ctor (_,ut,_,argt) ->
  1743:     bt (`TYP_function (argt,ut))
  1744: 
  1745:   | `SYMDEF_match_check _ ->
  1746:     `BTYP_function (`BTYP_tuple [], flx_bbool)
  1747: 
  1748:   | `SYMDEF_fun (_,pts,rt,_,_,_) ->
  1749:     let t = `TYP_function (typeof_list pts,rt) in
  1750:     bt t
  1751: 
  1752:   | `SYMDEF_union _ ->
  1753:     clierr sr ("Union "^id^" doesn't have a type")
  1754: 
  1755:   (* struct as function *)
  1756:   | `SYMDEF_cstruct (ls)
  1757:   | `SYMDEF_struct (ls) ->
  1758:     (* ARGGG WHAT A MESS *)
  1759:     let ts = map (fun (s,i,_) -> `AST_name (sr,s,[])) vs in
  1760:     let ts = map bt ts in
  1761:   (*
  1762:   print_endline "inner_typeofindex: struct";
  1763:   *)
  1764:     let ts = adjust_ts syms sr index ts in
  1765:     let t = `BTYP_function(bt (paramtype ls),`BTYP_inst (index,ts)) in
  1766:     (*
  1767:     print_endline ("Struct as function type is " ^ sbt syms.dfns t);
  1768:     *)
  1769:     t
  1770: 
  1771:   | `SYMDEF_class ->
  1772:     let ts = map (fun (s,i,_) -> `AST_name (sr,s,[])) vs in
  1773:     let ts = map bt ts in
  1774:     let ts = adjust_ts syms sr index ts in
  1775:     `BTYP_inst (index,ts)
  1776: 
  1777:   | _ ->
  1778:     clierr sr
  1779:     (
  1780:       "[typeofindex] Expected declaration of typed entity for index "^
  1781:       string_of_int index^", got " ^ id
  1782:     )
  1783:   end
  1784: 
  1785: and cal_apply syms sr ((be1,t1) as tbe1) ((be2,t2) as tbe2) : tbexpr_t =
  1786:   let rest =
  1787:     match unfold syms.dfns t1 with
  1788:     | `BTYP_lvalue (`BTYP_function (argt,rest))
  1789:     | `BTYP_function (argt,rest)
  1790:     | `BTYP_lvalue (`BTYP_cfunction (argt,rest))
  1791:     | `BTYP_cfunction (argt,rest) ->
  1792:       if type_match syms.dfns argt t2
  1793:       then rest
  1794:       else
  1795:         clierr sr
  1796:         (
  1797:           "[cal_apply] Function " ^
  1798:           sbe syms.dfns tbe1 ^
  1799:           "\nof type " ^
  1800:           sbt syms.dfns t1 ^
  1801:           "\napplied to argument " ^
  1802:           sbe syms.dfns tbe2 ^
  1803:           "\n of type " ^
  1804:           sbt syms.dfns t2 ^
  1805:           "\nwhich doesn't agree with parameter type\n" ^
  1806:           sbt syms.dfns argt
  1807:         )
  1808: 
  1809:     (* HACKERY TO SUPPORT STRUCT CONSTRUCTORS *)
  1810:     | `BTYP_inst (index,ts) ->
  1811:       begin match get_data syms.dfns index with
  1812:       { id=id;vs=vs;symdef=entry} ->
  1813:         begin match entry with
  1814:         | `SYMDEF_cstruct (cs)
  1815:         | `SYMDEF_struct (cs) -> t1
  1816:         | _ ->
  1817:           clierr sr
  1818:           (
  1819:             "[cal_apply] Attempt to apply non-struct " ^ id ^ ", type " ^
  1820:             sbt syms.dfns t1 ^
  1821:             " as constructor"
  1822:           )
  1823:         end
  1824:       end
  1825:     | _ ->
  1826:       clierr sr
  1827:       (
  1828:         "Attempt to apply non-function\n" ^
  1829:         sbe syms.dfns tbe1 ^
  1830:         "\nof type\n" ^
  1831:         sbt syms.dfns t1 ^
  1832:         "\nto argument of type\n" ^
  1833:         sbe syms.dfns tbe2
  1834:       )
  1835:   in
  1836:   (*
  1837:   print_endline
  1838:   (
  1839:     "---------------------------------------" ^
  1840:     "\nApply type " ^ sbt syms.dfns t1 ^
  1841:     "\nto argument of type " ^ sbt syms.dfns t2 ^
  1842:     "\nresult type is " ^ sbt syms.dfns rest ^
  1843:     "\n-------------------------------------"
  1844:   );
  1845:   *)
  1846: 
  1847:   let rest = varmap_subst syms.varmap rest in
  1848:   if rest = `BTYP_void then
  1849:     clierr sr
  1850:     (
  1851:       "[cal_apply] Function " ^
  1852:       sbe syms.dfns tbe1 ^
  1853:       "\nof type " ^
  1854:       sbt syms.dfns t1 ^
  1855:       "\napplied to argument " ^
  1856:       sbe syms.dfns tbe2 ^
  1857:       "\n of type " ^
  1858:       sbt syms.dfns t2 ^
  1859:       "\nreturns void"
  1860:     )
  1861:   else
  1862: 
  1863:   (* We have to allow type variables now .. the result
  1864:   should ALWAYS be determined, and independent of function
  1865:   return type unknowns, even if that means it is a recursive
  1866:   type, perhaps like 'Fix 0' ..: we should really test
  1867:   for the *function* return type variable not being
  1868:   eliminated ..
  1869:   *)
  1870:   (*
  1871:   if var_occurs rest
  1872:   then
  1873:     clierr sr
  1874:     (
  1875:       "[cal_apply] Type variable in return type applying\n" ^
  1876:         sbe syms.dfns tbe1 ^
  1877:         "\nof type\n" ^
  1878:         sbt syms.dfns t1 ^
  1879:         "\nto argument of type\n" ^
  1880:         sbe syms.dfns tbe2
  1881:     )
  1882:   ;
  1883:   *)
  1884:   match be1 with
  1885:   | `BEXPR_closure (i,ts) ->
  1886:     begin match Hashtbl.find syms.dfns i with
  1887:     | {symdef=`SYMDEF_fun _}
  1888:     | {symdef=`SYMDEF_callback _} ->
  1889:       `BEXPR_apply_prim (i,ts, (be2,lower t2)),rest
  1890:     | {symdef=`SYMDEF_function _} ->
  1891:       `BEXPR_apply_direct (i,ts, (be2,lower t2)),rest
  1892:     | _ -> (* needed temporarily for constructors .. *)
  1893:       `BEXPR_apply_direct (i,ts, (be2,lower t2)),rest
  1894: 
  1895:     end
  1896:   | _ ->
  1897:     `BEXPR_apply ((be1,lower t1), (be2,lower t2)),rest
  1898: 
  1899: and koenig_lookup syms rs sra id' name_map fn t2 ts =
  1900:   (*
  1901:   print_endline ("Applying Koenig lookup for " ^ fn);
  1902:   *)
  1903:   let entries =
  1904:     try Hashtbl.find name_map fn
  1905:     with Not_found ->
  1906:       clierr sra
  1907:       (
  1908:         "Koenig lookup: can't find name "^
  1909:         fn^ " in " ^
  1910:         (match id' with
  1911:         | "" -> "top level module"
  1912:         | _ -> "module '" ^ id' ^ "'"
  1913:         )
  1914:       )
  1915:   in
  1916:   match entries with
  1917:   | FunctionEntry fs ->
  1918:     (*
  1919:     print_endline ("Got candidates: " ^ string_of_entry_set entries);
  1920:     *)
  1921:     begin match resolve_overload' syms rs sra fs fn [t2] ts with
  1922:     | Some (index'',t,mgu,ts) ->
  1923:       (* print_endline "Overload resolution OK"; *)
  1924:       `BEXPR_closure (index'',ts),
  1925:        typeofindex_with_ts syms sra index'' ts
  1926: 
  1927: 
  1928:     | None ->
  1929:         (*
  1930:         let n = ref 0
  1931:         in Hashtbl.iter (fun _ _ -> incr n) name_map;
  1932:         print_endline ("module defines " ^ string_of_int !n^ " entries");
  1933:         *)
  1934:         clierr sra
  1935:         (
  1936:           "[flx_ebind] Koenig lookup: Can't find match for " ^ fn ^
  1937:           "\ncandidates are: " ^ full_string_of_entry_set syms.dfns entries
  1938:         )
  1939:     end
  1940:   | NonFunctionEntry _ -> clierr sra "Koenig lookup expected function"
  1941: 
  1942: (* this routine has to return a function or procedure .. *)
  1943: and lookup_qn_with_sig
  1944:   syms
  1945:   sra srn
  1946:   env
  1947:   (qn:qualified_name_t)
  1948:   (signs:btypecode_t list)
  1949: =
  1950: try
  1951:   lookup_qn_with_sig'
  1952:     syms
  1953:     sra srn
  1954:     env rsground
  1955:     qn
  1956:     signs
  1957: with
  1958:   | Free_fixpoint b ->
  1959:     clierr sra
  1960:     ("Recursive dependency resolving name " ^ string_of_qualified_name qn)
  1961: 
  1962: and lookup_qn_with_sig'
  1963:   syms
  1964:   sra srn
  1965:   env (rs:recstop)
  1966:   (qn:qualified_name_t)
  1967:   (signs:btypecode_t list)
  1968: : tbexpr_t =
  1969:   (*
  1970:   print_endline ("[lookup_qn_with_sig] " ^ string_of_qualified_name qn);
  1971:   print_endline ("sigs = " ^ catmap "," (sbt syms.dfns) signs);
  1972:   print_endline ("expr_fixlist is " ^
  1973:     catmap ","
  1974:     (fun (e,d) -> string_of_expr e ^ " [depth " ^si d^"]")
  1975:     rs.expr_fixlist
  1976:   );
  1977:   *)
  1978:   let bt sr t =
  1979:     (*
  1980:     print_endline "NON PROPAGATING BIND TYPE";
  1981:     *)
  1982:     bind_type syms env sr t
  1983:   in
  1984:   let handle_nonfunction_index index ts =
  1985:     begin match get_data syms.dfns index with
  1986:     {id=id;sr=sr;parent=parent;vs=vs;privmap=table;dirs=dirs;symdef=entry}
  1987:     ->
  1988:       begin match entry with
  1989:       | `SYMDEF_inherit_fun qn ->
  1990:           clierr sr "Chasing functional inherit in lookup_qn_with_sig'";
  1991: 
  1992:       | `SYMDEF_inherit qn ->
  1993:           clierr sr "Chasing inherit in lookup_qn_with_sig'";
  1994: 
  1995:       | `SYMDEF_regmatch _
  1996:       | `SYMDEF_reglex _
  1997:       | `SYMDEF_cstruct _
  1998:       | `SYMDEF_struct _ ->
  1999:         (*
  2000:         print_endline ("Struct constructor found, type= " ^ sbt syms.dfns t);
  2001:         *)
  2002: (*
  2003: print_endline (id ^ ": lookup_qn_with_sig: struct/regmatch/lex");
  2004: *)
  2005:         (*
  2006:         let ts = adjust_ts syms sr index ts in
  2007:         *)
  2008:         let sign = try hd signs with _ -> assert false in
  2009:         let t = typeofindex_with_ts syms sr index ts in
  2010:         begin match t with
  2011:         | `BTYP_function (a,_) ->
  2012:           if not (type_match syms.dfns a sign) then
  2013:             clierr sr
  2014:             (
  2015:               "[lookup_qn_with_sig] Struct constructor for "^id^" has wrong signature, got:\n" ^
  2016:               sbt syms.dfns t ^
  2017:               "\nexpected:\n" ^
  2018:               sbt syms.dfns sign
  2019:             )
  2020:         | _ -> assert false
  2021:         end
  2022:         ;
  2023:         `BEXPR_closure (index,ts),
  2024:         t
  2025: 
  2026:       | `SYMDEF_const (t,_,_)
  2027:       | `SYMDEF_val t
  2028:       | `SYMDEF_var t
  2029:       | `SYMDEF_parameter t
  2030:         ->
  2031: print_endline (id ^ ": lookup_qn_with_sig: val/var");
  2032:         (*
  2033:         let ts = adjust_ts syms sr index ts in
  2034:         *)
  2035:         let t = bt sr t in
  2036:         let bvs = map (fun (s,i,tp) -> s,i) vs in
  2037:         let t = try tsubst bvs ts t with _ -> failwith "[lookup_qn_with_sig] WOOPS" in
  2038:         begin match t with
  2039:         | `BTYP_function (a,b) ->
  2040:           let sign = try hd signs with _ -> assert false in
  2041:           if not (type_match syms.dfns a sign) then
  2042:           clierr srn
  2043:           (
  2044:             "[lookup_qn_with_sig] Expected variable "^id ^
  2045:             "<" ^ si index ^ "> to have function type with signature " ^
  2046:             sbt syms.dfns sign ^
  2047:             ", got function type:\n" ^
  2048:             sbt syms.dfns t
  2049:           )
  2050:           else
  2051:             `BEXPR_name (index, ts),
  2052:             t
  2053: 
  2054:         | _ ->
  2055:           clierr srn
  2056:           (
  2057:             "[lookup_qn_with_sig] expected variable " ^
  2058:             id ^ "<" ^ si index ^ "> to be of function type, got:\n" ^
  2059:             sbt syms.dfns t
  2060: 
  2061:           )
  2062:         end
  2063:       | _ ->
  2064:         clierr sr
  2065:         (
  2066:           "[lookup_qn_with_sig] Named Non function entry "^id^
  2067:           " must be function type: requires struct," ^
  2068:           "or value or variable of function type"
  2069:         )
  2070:       end
  2071:     end
  2072:   in
  2073:   match qn with
  2074:   | `AST_callback (sr,qn) ->
  2075:     failwith "[lookup_qn_with_sig] Callbacks not implemented yet"
  2076: 
  2077:   | `AST_the (sr,qn) ->
  2078:     lookup_qn_with_sig' syms sra srn
  2079:     env rs
  2080:     qn signs
  2081: 
  2082:   | `AST_void _ -> clierr sra "qualified-name is void"
  2083: 
  2084:   | `AST_case_tag _ -> clierr sra "Can't lookup case tag here"
  2085: 
  2086:   (* WEIRD .. this is a qualified name syntactically ..
  2087:     but semantically it belongs in bind_expression
  2088:     where this code is duplicated ..
  2089: 
  2090:     AH NO it isn't. Here, we always return a function
  2091:     type, even for constant constructors (because we
  2092:     have a signature ..)
  2093:   *)
  2094:   | `AST_typed_case (sr,v,t) ->
  2095:     let t = bt sr t in
  2096:     begin match unfold syms.dfns t with
  2097:     | `BTYP_unitsum k ->
  2098:       if v<0 or v>= k
  2099:       then clierr sra "Case index out of range of sum"
  2100:       else
  2101:         let ct = `BTYP_function (unit_t,t) in
  2102:         `BEXPR_case (v,t),ct
  2103: 
  2104:     | `BTYP_sum ls ->
  2105:       if v<0 or v >= length ls
  2106:       then clierr sra "Case index out of range of sum"
  2107:       else let vt = nth ls v in
  2108:       let ct = `BTYP_function (vt,t) in
  2109:       `BEXPR_case (v,t), ct
  2110: 
  2111:     | _ ->
  2112:       clierr sr
  2113:       (
  2114:         "[lookup_qn_with_sig] Type of case must be sum, got " ^
  2115:         sbt syms.dfns t
  2116:       )
  2117:     end
  2118: 
  2119:   | `AST_name (sr,name,ts) ->
  2120:     (*
  2121:     print_endline "Looking up name with sig ..";
  2122:     *)
  2123:     let ts = map (bt sr) ts in
  2124:     lookup_name_with_sig
  2125:       syms
  2126:       sra srn
  2127:       env rs name ts signs
  2128: 
  2129:   | `AST_index (sr,name,index) ->
  2130:     begin match get_data syms.dfns index with
  2131:     | {id=id; sr=sra; symdef=entry} ->
  2132:     match entry with
  2133:     | `SYMDEF_fun _
  2134:     | `SYMDEF_function _
  2135:     | `SYMDEF_match_check _
  2136:       ->
  2137:       (* THIS IS A HACK! THERE IS NOTHING TO RESOLVE, WE KNOW
  2138:       WHICH FUNCTION IS CHOSEN ALREADY .. WE SEEM TO BE DOING
  2139:       THIS OVERLOAD JUST TO FIND THE TS VALUES
  2140:       *)
  2141:       begin match
  2142:         resolve_overload'
  2143:         syms rs sra [index] name signs []
  2144:       with
  2145:       | Some (index,t,mgu,ts) ->
  2146:         `BEXPR_closure (index,ts),
  2147:         inner_typeofindex_with_ts syms sr rs index ts
  2148: 
  2149:       | None ->
  2150:         clierr sra
  2151:         (
  2152:           "[lookup_qn_with_sig] Unable to resolve overload of synthetic function " ^
  2153:           name
  2154:         )
  2155:       end
  2156: 
  2157:     | _ ->
  2158:       handle_nonfunction_index index []
  2159:     end
  2160: 
  2161:   | `AST_lookup (sr,(qn',name,ts)) ->
  2162:     let m =  eval_module_expr syms env qn' in
  2163:     match m with (Simple_module (impl, ts',htab,dirs)) ->
  2164:     (* let n = length ts in *)
  2165:     let ts = map (bt sr)( ts' @ ts) in
  2166:     (*
  2167:     print_endline ("Module " ^ si impl ^ "[" ^ catmap "," (sbt syms.dfns) ts' ^"]");
  2168:     *)
  2169:     let env' = mk_bare_env syms impl in
  2170:     let tables = get_pub_tables syms env' rs dirs in
  2171:     let result = lookup_name_in_table_dirs htab tables sr name in
  2172:     begin match result with
  2173:     | None ->
  2174:       clierr sr
  2175:       (
  2176:         "[lookup_qn_with_sig] AST_lookup: Simple_module: Can't find name " ^ name
  2177:       )
  2178:     | Some entries -> match entries with
  2179:     | NonFunctionEntry (index) ->
  2180:       handle_nonfunction_index index ts
  2181: 
  2182:     | FunctionEntry fs ->
  2183:       match
  2184:         resolve_overload'
  2185:         syms rs sra fs name signs ts
  2186:       with
  2187:       | Some (index,t,mgu,ts) ->
  2188:         (*
  2189:         print_endline ("Resolved overload for " ^ name);
  2190:         print_endline ("ts = [" ^ catmap ", " (sbt syms.dfns) ts ^ "]");
  2191:         *)
  2192:         (*
  2193:         let ts = adjust_ts syms sr index ts in
  2194:         *)
  2195:         `BEXPR_closure (index,ts),
  2196:          typeofindex_with_ts syms sr index ts
  2197: 
  2198:       | None ->
  2199:         clierr sra
  2200:         (
  2201:           "[lookup_qn_with_sig] (Simple module) Unable to resolve overload of " ^
  2202:           string_of_qualified_name qn ^
  2203:           " of (" ^ catmap "," (sbt syms.dfns) signs ^")\n" ^
  2204:           "candidates are: " ^ full_string_of_entry_set syms.dfns entries
  2205:         )
  2206:     end
  2207: 
  2208: and lookup_name_with_sig
  2209:   syms
  2210:   sra srn
  2211:   env
  2212:   (rs:recstop)
  2213:   (name : string)
  2214:   (ts : btypecode_t list)
  2215:   (t2:btypecode_t list)
  2216: : tbexpr_t =
  2217:   (*
  2218:   print_endline ("[lookup_name_with_sig] " ^ name ^
  2219:     " of " ^ catmap "," (sbt syms.dfns) t2)
  2220:   ;
  2221:   *)
  2222:   match env with
  2223:   | [] ->
  2224:     clierr srn
  2225:     (
  2226:       "[lookup_name_with_sig] Can't find " ^ name ^
  2227:       " of " ^ catmap "," (sbt syms.dfns) t2
  2228:     )
  2229:   | (_,_,table,dirs)::tail ->
  2230:     match
  2231:       lookup_name_in_table_dirs_with_sig
  2232:       (table, dirs)
  2233:       syms env rs
  2234:       sra srn name ts t2
  2235:     with
  2236:     | Some result -> (result:>tbexpr_t)
  2237:     | None ->
  2238:       let tbx=
  2239:         lookup_name_with_sig
  2240:           syms
  2241:           sra srn
  2242:           tail rs name ts t2
  2243:        in (tbx:>tbexpr_t)
  2244: 
  2245: and handle_function
  2246:   syms
  2247:   env (rs:recstop)
  2248:   sra srn
  2249:   name
  2250:   ts
  2251:   index
  2252: : tbexpr_t
  2253: =
  2254:   match get_data syms.dfns index with
  2255:   {
  2256:     id=id;sr=sr;vs=vs;parent=parent;
  2257:     privmap=tabl;dirs=dirs;
  2258:     symdef=entry
  2259:   }
  2260:   ->
  2261:   match entry with
  2262:   | `SYMDEF_match_check _
  2263:   | `SYMDEF_function _
  2264:   | `SYMDEF_fun _
  2265:   | `SYMDEF_struct _
  2266:   | `SYMDEF_cstruct _
  2267:   | `SYMDEF_nonconst_ctor _
  2268:   | `SYMDEF_regmatch _
  2269:   | `SYMDEF_reglex _
  2270:   | `SYMDEF_callback _
  2271:     ->
  2272:     let t = inner_typeofindex_with_ts syms sr rs index ts
  2273:     in
  2274:     `BEXPR_closure (index,ts),
  2275:     (
  2276:       match t with
  2277:       | `BTYP_cfunction (s,d) as t -> t
  2278:       | `BTYP_function (s,d) as t -> t
  2279:       | t ->
  2280:         ignore begin
  2281:           match t with
  2282:           | `BTYP_fix _ -> raise (Free_fixpoint t)
  2283:           | _ -> try unfold syms.dfns t with
  2284:           | _ -> raise (Free_fixpoint t)
  2285:         end
  2286:         ;
  2287:         clierr sra
  2288:         (
  2289:           "[handle_function]: closure operator expected '"^name^"' to have function type, got '"^
  2290:           sbt syms.dfns t ^ "'"
  2291:         )
  2292:     )
  2293:   | `SYMDEF_type_alias (`TYP_typefun _) ->
  2294:     (* THIS IS A HACK .. WE KNOW THE TYPE IS NOT NEEDED BY THE CALLER .. *)
  2295:     (* let t = inner_typeofindex_with_ts syms sr rs index ts in *)
  2296:     let t = `BTYP_function (`BTYP_type,`BTYP_type) in
  2297:     `BEXPR_closure (index,ts),
  2298:     (
  2299:       match t with
  2300:       | `BTYP_function (s,d) as t -> t
  2301:       | t ->
  2302:         ignore begin
  2303:           match t with
  2304:           | `BTYP_fix _ -> raise (Free_fixpoint t)
  2305:           | _ -> try unfold syms.dfns t with
  2306:           | _ -> raise (Free_fixpoint t)
  2307:         end
  2308:         ;
  2309:         clierr sra
  2310:         (
  2311:           "[handle_function]: closure operator expected '"^name^"' to have function type, got '"^
  2312:           sbt syms.dfns t ^ "'"
  2313:         )
  2314:     )
  2315: 
  2316:   | _ ->
  2317:     clierr sra
  2318:     (
  2319:       "[handle_function] Expected "^name^" to be function, got: " ^
  2320:       string_of_symdef entry name vs
  2321:     )
  2322: 
  2323: and handle_variable syms
  2324:   env (rs:recstop)
  2325:   index id sr ts t t2
  2326: =
  2327:   (* HACKED the params argument to [] .. this is WRONG!! *)
  2328:   let bt sr t =
  2329:     bind_type' syms env rs sr t []
  2330:   in
  2331: 
  2332:     (* we have to check the variable is the right type *)
  2333:     let t = bt sr t in
  2334:     let ts = adjust_ts syms sr index ts in
  2335:     let vs = find_vs syms index in
  2336:     let bvs = map (fun (s,i,tp) -> s,i) vs in
  2337:     let t = tsubst bvs ts t in
  2338:     let t = match t with | `BTYP_lvalue t -> t | t -> t in
  2339:     begin match t with
  2340:     | `BTYP_function (d,c) ->
  2341:       if not (type_match syms.dfns d t2) then
  2342:       clierr sr
  2343:       (
  2344:         "[handle_variable(1)] Expected variable "^id ^
  2345:         "<" ^ si index ^ "> to have function type with signature " ^
  2346:         sbt syms.dfns t2 ^
  2347:         ", got function type:\n" ^
  2348:         sbt syms.dfns t
  2349:       )
  2350:       else
  2351:         (*
  2352:         let ts = adjust_ts syms sr index ts in
  2353:         *)
  2354:         Some
  2355:         (
  2356:           `BEXPR_name (index, ts),t
  2357:           (* should equal t ..
  2358:           typeofindex_with_ts syms sr index ts
  2359:           *)
  2360:         )
  2361: 
  2362:     (* anything other than function type, dont check the sig,
  2363:        just return it..
  2364:     *)
  2365:     | _ ->  Some (`BEXPR_name (index,ts),t)
  2366:     end
  2367: 
  2368: and lookup_name_in_table_dirs_with_sig (table, dirs)
  2369:   syms
  2370:   env (rs:recstop)
  2371:   sra srn name (ts:btypecode_t list) (t2: btypecode_t list)
  2372: : tbexpr_t option
  2373: =
  2374:   (*
  2375:   print_endline
  2376:   (
  2377:     "LOOKUP NAME "^name ^"["^
  2378:     catmap "," (sbt syms.dfns) ts ^
  2379:     "] IN TABLE DIRS WITH SIG " ^ catmap "," (sbt syms.dfns) t2
  2380:   );
  2381:   *)
  2382:   let result:entry_set_t =
  2383:     match lookup_name_in_htab table name  with
  2384:     | Some x -> x
  2385:     | None -> FunctionEntry []
  2386:   in
  2387:   match result with
  2388:   | NonFunctionEntry (index) ->
  2389:     begin match get_data syms.dfns index with
  2390:     {id=id;sr=sr;parent=parent;vs=vs;pubmap=pubmap;symdef=entry}->
  2391:     (*
  2392:     print_endline ("FOUND " ^ id);
  2393:     *)
  2394:     begin match entry with
  2395:     | `SYMDEF_inherit _ ->
  2396:       clierr sra "Woops found inherit in lookup_name_in_table_dirs_with_sig"
  2397:     | `SYMDEF_inherit_fun _ ->
  2398:       clierr sra "Woops found inherit function in lookup_name_in_table_dirs_with_sig"
  2399: 
  2400:     | `SYMDEF_regmatch _
  2401:     | `SYMDEF_reglex _
  2402:     | `SYMDEF_cstruct _
  2403:     | `SYMDEF_struct _
  2404:     | `SYMDEF_nonconst_ctor _
  2405:       ->
  2406:         (*
  2407:         print_endline "lookup_name_in_table_dirs_with_sig finds struct constructor";
  2408:         *)
  2409:         let ro =
  2410:           resolve_overload'
  2411:           syms rs sra [index] name t2 ts
  2412:         in
  2413:           begin match ro with
  2414:           | Some (index,t,mgu,ts) ->
  2415:             let tb : tbexpr_t =
  2416:               handle_function
  2417:               syms
  2418:               env rs
  2419:               sra srn name ts index
  2420:             in
  2421:               Some tb
  2422:           | None -> None
  2423:           end
  2424: 
  2425:     | `SYMDEF_class ->
  2426:       (*
  2427:       print_endline ("Found a class "^name^", look for constructor with hacked name _ctor_"^name);
  2428:       *)
  2429:       let entries = lookup_name_in_htab pubmap ("_ctor_" ^ name) in
  2430:       begin match entries with
  2431:       | None -> clierr sr "Unable to find any constructors for this class"
  2432:       | Some (NonFunctionEntry _) -> syserr sr
  2433:         "[lookup_name_in_table_dirs_with_sig] Expected constructor to be a procedure"
  2434: 
  2435:       | Some (FunctionEntry fs) ->
  2436:         (*
  2437:         print_endline ("Ok, found "^si (length fs) ^"constructors for " ^ name);
  2438:         *)
  2439:         let ro =
  2440:           resolve_overload'
  2441:           syms rs sra fs ("_ctor_" ^ name) t2 ts
  2442:         in
  2443:         match ro with
  2444:           | Some (index,t,mgu,ts) ->
  2445:             let ((_,tt) as tb) =
  2446:               handle_function
  2447:               syms
  2448:               env rs
  2449:               sra srn name ts index
  2450:             in
  2451:               (*
  2452:               print_endline ("SUCCESS: overload chooses " ^ full_string_of_entry_kind syms.dfns index);
  2453:               print_endline ("Value of ts is " ^ catmap "," (sbt syms.dfns) ts);
  2454:               print_endline ("Instantiated closure value is " ^ sbe syms.dfns tb);
  2455:               print_endline ("type is " ^ sbt syms.dfns tt);
  2456:               *)
  2457:               Some tb
  2458:           | None ->
  2459:             clierr sr "Unable to find matching constructor"
  2460:       end
  2461:       (*
  2462:       lookup_name_in_table_dirs_with_sig (table, dirs)
  2463:       syms env rs sra srn ("_ctor_" ^ name) ts t2
  2464:       *)
  2465: 
  2466:     | `SYMDEF_abs _
  2467:     | `SYMDEF_cclass _
  2468:     | `SYMDEF_union _
  2469:     | `SYMDEF_type_alias _ ->
  2470: 
  2471:       (* recursively lookup using "_ctor_" ^ name :
  2472:          WARNING: we might find a constructor with the
  2473:          right name for a different cclass than this one,
  2474:          it isn't clear this is wrong though.
  2475:       *)
  2476:       (*
  2477:       print_endline "mapping type name to _ctor_type";
  2478:       *)
  2479:       lookup_name_in_table_dirs_with_sig (table, dirs)
  2480:       syms env rs sra srn ("_ctor_" ^ name) ts t2
  2481: 
  2482:     | `SYMDEF_const_ctor (_,t,_)
  2483:     | `SYMDEF_const (t,_,_)
  2484:     | `SYMDEF_var t
  2485:     | `SYMDEF_val t
  2486:     | `SYMDEF_parameter t
  2487:       ->
  2488:       let sign = try hd t2 with _ -> assert false in
  2489:       handle_variable syms env rs index id srn ts t sign
  2490:     | _
  2491:       ->
  2492:         clierr sra
  2493:         (
  2494:           "Expected " ^id^
  2495:           " to be struct or variable of function type, got " ^
  2496:           string_of_symdef entry id vs
  2497:         )
  2498:     end
  2499:     end
  2500: 
  2501:   | FunctionEntry fs ->
  2502:     (*
  2503:     print_endline ("Found function set size " ^ si (length fs));
  2504:     *)
  2505:     let ro =
  2506:       resolve_overload'
  2507:       syms rs sra fs name t2 ts
  2508:     in
  2509:     match ro with
  2510:       | Some (index,t,mgu,ts) ->
  2511:         let ((_,tt) as tb) =
  2512:           handle_function
  2513:           syms
  2514:           env rs
  2515:           sra srn name ts index
  2516:         in
  2517:           (*
  2518:           print_endline ("SUCCESS: overload chooses " ^ full_string_of_entry_kind syms.dfns index);
  2519:           print_endline ("Value of ts is " ^ catmap "," (sbt syms.dfns) ts);
  2520:           print_endline ("Instantiated closure value is " ^ sbe syms.dfns tb);
  2521:           print_endline ("type is " ^ sbt syms.dfns tt);
  2522:           *)
  2523:           Some tb
  2524: 
  2525:       | None ->
  2526:         (*
  2527:         print_endline "Can't overload: Trying opens";
  2528:         *)
  2529:         let opens : entry_set_t list =
  2530:           concat
  2531:           (
  2532:             map
  2533:             (fun table ->
  2534:               match lookup_name_in_htab table name with
  2535:               | Some x -> [x]
  2536:               | None -> []
  2537:             )
  2538:             dirs
  2539:           )
  2540:         in
  2541:         (*
  2542:         print_endline (si (length opens) ^ " OPENS BUILT for " ^ name);
  2543:         *)
  2544:         match opens with
  2545:         | [NonFunctionEntry i] when
  2546:           (
  2547:               match get_data syms.dfns i with
  2548:               {id=id;sr=sr;parent=parent;vs=vs;pubmap=pubmap;symdef=entry}->
  2549:               (*
  2550:               print_endline ("FOUND " ^ id);
  2551:               *)
  2552:               match entry with
  2553:               | `SYMDEF_abs _
  2554:               | `SYMDEF_cclass _
  2555:               | `SYMDEF_union _ -> true
  2556:               | _ -> false
  2557:            ) ->
  2558:              (*
  2559:              print_endline "mapping type name to _ctor_type2";
  2560:              *)
  2561:              lookup_name_in_table_dirs_with_sig (table, dirs)
  2562:              syms env rs sra srn ("_ctor_" ^ name) ts t2
  2563:         | _ ->
  2564:         let fs =
  2565:           match opens with
  2566:           | [NonFunctionEntry i] -> [i]
  2567:           | [FunctionEntry ii] -> ii
  2568:           | _ -> merge_functions opens name
  2569:         in
  2570:           let ro =
  2571:             resolve_overload'
  2572:             syms rs sra fs name t2 ts
  2573:           in
  2574:           (*
  2575:           print_endline "OVERLOAD RESOLVED .. ";
  2576:           *)
  2577:           match ro with
  2578:           | Some (result,t,mgu,ts) ->
  2579:             let tb : tbexpr_t =
  2580:               handle_function
  2581:               syms
  2582:               env rs
  2583:               sra srn name ts result
  2584:             in
  2585:               Some tb
  2586:           | None ->
  2587:             (*
  2588:             print_endline "FAILURE"; flush stdout;
  2589:             *)
  2590:             None
  2591: 
  2592: and bind_regdef syms env regexp_exclude e =
  2593:   let bd e = bind_regdef syms env regexp_exclude e in
  2594:   match e with
  2595:   | REGEXP_group (n,e) -> REGEXP_group (n, bd e)
  2596:   | REGEXP_seq (e1,e2) -> REGEXP_seq (bd e1, bd e2)
  2597:   | REGEXP_alt (e1,e2) -> REGEXP_alt (bd e1, bd e2)
  2598:   | REGEXP_aster e -> REGEXP_aster (bd e)
  2599:   | REGEXP_name qn ->
  2600:     begin match lookup_qn_in_env syms env qn with
  2601:     | i,_ ->
  2602:       if mem i regexp_exclude
  2603:       then
  2604:         let sr = src_of_expr (qn:>expr_t) in
  2605:         clierr sr
  2606:         (
  2607:           "[bind_regdef] Regdef " ^ string_of_qualified_name qn ^
  2608:           " depends on itself"
  2609:         )
  2610:       else
  2611:         begin
  2612:           match get_data syms.dfns i with
  2613:           {symdef=entry} ->
  2614:           match entry with
  2615:           | `SYMDEF_regdef e ->
  2616:             bind_regdef syms env (i::regexp_exclude) e
  2617:           | _ ->
  2618:             let sr = src_of_expr (qn:>expr_t) in
  2619:             clierr sr
  2620:             (
  2621:               "[bind_regdef] Expected " ^ string_of_qualified_name qn ^
  2622:               " to be regdef"
  2623:             )
  2624:         end
  2625:     end
  2626: 
  2627:   | x -> x
  2628: 
  2629: and handle_map sr (f,ft) (a,at) =
  2630:     let t =
  2631:       match ft with
  2632:       | `BTYP_function (d,c) ->
  2633:         begin match at with
  2634:         | `BTYP_inst (i,[t]) ->
  2635:           if t <> d
  2636:           then clierr sr
  2637:             ("map type of data structure index " ^
  2638:             "must agree with function domain")
  2639:           else
  2640:             `BTYP_inst (i,[c])
  2641:         | _ -> clierr sr "map requires instance"
  2642:         end
  2643:       | _ -> clierr sr "map non-function"
  2644:     in
  2645:       (* actually this part is easy, it's just
  2646:       applies ((map[i] f) a) where map[i] denotes
  2647:       the map function generated for data structure i
  2648:       *)
  2649:       failwith "MAP NOT IMPLEMENTED"
  2650: 
  2651: and bind_expression' syms env (rs:recstop) e args
  2652: : tbexpr_t =
  2653:   (*
  2654:   print_endline ("[bind_expression'] " ^ string_of_expr e);
  2655:   print_endline ("expr_fixlist is " ^
  2656:     catmap ","
  2657:     (fun (e,d) -> string_of_expr e ^ " [depth " ^si d^"]")
  2658:     rs.expr_fixlist
  2659:   );
  2660:   *)
  2661:   if mem_assq e rs.expr_fixlist
  2662:   then raise (Expr_recursion e)
  2663:   ;
  2664:   let be e' = bind_expression' syms env
  2665:     { rs with expr_fixlist=(e,rs.depth)::rs.expr_fixlist; depth=rs.depth+1} e' [] in
  2666:   let bt sr t =
  2667:     (* we're really wanting to call bind type and propagate depth ? *)
  2668:     let t = bind_type' syms env
  2669:       { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist; depth=rs.depth +1 }
  2670:       sr t []
  2671:     in
  2672:     let t = beta_reduce syms [] t in
  2673:     t
  2674:   in
  2675:   let ti sr i ts =
  2676:     inner_typeofindex_with_ts syms sr
  2677:     { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist; depth = rs.depth + 1}
  2678:                                (* CHANGED THIS ------------------*******)
  2679:     i ts
  2680:   in
  2681: 
  2682:   (* model infix operator as function call *)
  2683:   let apl2 (sri:range_srcref) (fn : string) (tup:expr_t list) =
  2684:     let sr = rslist tup in
  2685:     `AST_apply
  2686:     (
  2687:       sr,
  2688:       (
  2689:         `AST_name (sri,fn,[]),
  2690:         `AST_tuple (sr,tup)
  2691:       )
  2692:     )
  2693:   in
  2694:   (*
  2695:   print_endline ("Binding expression " ^ string_of_expr e ^ " depth=" ^ string_of_int depth);
  2696:   print_endline ("environment is:");
  2697:   print_env env;
  2698:   print_endline "==";
  2699:   *)
  2700:   let rt t = Flx_maps.reduce_type (lstrip syms.dfns (beta_reduce syms [] t)) in
  2701:   let sr = src_of_expr e in
  2702:   match e with
  2703:   | `AST_vsprintf _
  2704:   | `AST_type_match _
  2705:   | `AST_noexpand _
  2706:   | `AST_letin _
  2707:   | `AST_cond _
  2708:   | `AST_typeof _
  2709:   | `AST_as _
  2710:   | `AST_void _
  2711:   | `AST_arrow _
  2712:   | `AST_longarrow _
  2713:   | `AST_superscript _
  2714:   | `AST_ellipsis _
  2715:   | `AST_parse _
  2716:   | `AST_setunion _
  2717:   | `AST_setintersection _
  2718:   | `AST_macro_ctor _
  2719:   | `AST_macro_statements  _
  2720:     ->
  2721:       clierr sr
  2722:      ("[bind_expression] Expected expression, got " ^ string_of_expr e)
  2723: 
  2724:   | `AST_callback (sr,qn) ->
  2725:     let es,ts = lookup_qn_in_env2' syms env rs qn in
  2726:     begin match es with
  2727:     | FunctionEntry [index] ->
  2728:        print_endline "Callback closure ..";
  2729:        let ts = map (bt sr) ts in
  2730:        `BEXPR_closure (index, ts),
  2731:        ti sr index ts
  2732:     | NonFunctionEntry  _
  2733:     | _ -> clierr sr
  2734:       "'callback' expression denotes non-singleton function set"
  2735:     end
  2736: 
  2737:   | `AST_sparse (sr,e,nt,nts) ->
  2738:     let e = be e in
  2739:     (*
  2740:     print_endline ("Calculating AST_parse, symbol " ^ nt);
  2741:     *)
  2742:     let t = cal_glr_attr_type syms sr nts in
  2743:     (*
  2744:     print_endline (".. DONE: Calculating AST_parse, type=" ^ sbt syms.dfns t);
  2745:     *)
  2746:     `BEXPR_parse (e,nts),`BTYP_sum [unit_t;t]
  2747: 
  2748:   | `AST_expr (sr,s,t) ->
  2749:     let t = bt sr t in
  2750:     `BEXPR_expr (s,t),t
  2751: 
  2752:   | `AST_andlist (sri,ls) ->
  2753:     begin let mksum a b = apl2 sri "land" [a;b] in
  2754:     match ls with
  2755:     | h::t -> be (fold_left mksum h t)
  2756:     | [] -> clierr sri "Not expecting empty and list"
  2757:     end
  2758: 
  2759:   | `AST_orlist (sri,ls) ->
  2760:     begin let mksum a b = apl2 sri "lor" [a;b] in
  2761:     match ls with
  2762:     | h::t -> be (fold_left mksum h t)
  2763:     | [] -> clierr sri "Not expecting empty or list"
  2764:     end
  2765: 
  2766:   | `AST_sum (sri,ls) ->
  2767:     begin let mksum a b = apl2 sri "add" [a;b] in
  2768:     match ls with
  2769:     | h::t -> be (fold_left mksum h t)
  2770:     | [] -> clierr sri "Not expecting empty product (unit)"
  2771:     end
  2772: 
  2773:   | `AST_product (sri,ls) ->
  2774:     begin let mkprod a b = apl2 sri "mul" [a;b] in
  2775:     match ls with
  2776:     | h::t -> be (fold_left mkprod h t)
  2777:     | [] -> clierr sri "Not expecting empty sum (void)"
  2778:     end
  2779: 
  2780:   | `AST_coercion (sr,(x,t)) ->
  2781:     let (e',t') as x' = be x in
  2782:     let t'' = bt sr t in
  2783:     if type_eq syms.dfns t' t'' then x'
  2784:     else
  2785:     let t' = Flx_maps.reduce_type t' in (* src *)
  2786:     let t'' = Flx_maps.reduce_type t'' in (* dst *)
  2787:     begin match t',t'' with
  2788:     | `BTYP_lvalue(`BTYP_inst (i,[])),`BTYP_unitsum n
  2789:     | `BTYP_inst (i,[]),`BTYP_unitsum n ->
  2790:       begin match Hashtbl.find syms.dfns i with
  2791:       | { id="int"; symdef=`SYMDEF_abs (_,`StrTemplate "int",_) }  ->
  2792:         begin match e' with
  2793:         | `BEXPR_literal (`AST_int (kind,big)) ->
  2794:           let m =
  2795:             try Big_int.int_of_big_int big
  2796:             with _ -> clierr sr "Integer is too large for unitsum"
  2797:           in
  2798:           if m >=0 && m < n then
  2799:             `BEXPR_case (m,t''),t''
  2800:           else
  2801:             clierr sr "Integer is out of range for unitsum"
  2802:         | _ ->
  2803:           let inttype = t' in
  2804:           let zero = `BEXPR_literal (`AST_int ("int",Big_int.zero_big_int)),t' in
  2805:           let xn = `BEXPR_literal (`AST_int ("int",Big_int.big_int_of_int n)),t' in
  2806:           `BEXPR_range_check (zero,x',xn),`BTYP_unitsum n
  2807: 
  2808:         end
  2809:       | _ ->
  2810:         clierr sr ("Attempt to to coerce type:\n"^
  2811:         sbt syms.dfns t'
  2812:         ^"to unitsum " ^ si n)
  2813:       end
  2814: 
  2815:     | `BTYP_lvalue(`BTYP_record ls'),`BTYP_record ls''
  2816:     | `BTYP_record ls',`BTYP_record ls'' ->
  2817:       begin
  2818:       try
  2819:       `BEXPR_record
  2820:       (
  2821:         map
  2822:         (fun (s,t)->
  2823:           match list_assoc_index ls' s with
  2824:           | Some j ->
  2825:             let tt = assoc s ls' in
  2826:             if type_eq syms.dfns t tt then
  2827:               s,(`BEXPR_get_n (j,x'),t)
  2828:             else clierr sr (
  2829:               "Source Record field '" ^ s ^ "' has type:\n" ^
  2830:               sbt syms.dfns tt ^ "\n" ^
  2831:               "but coercion target has the different type:\n" ^
  2832:               sbt syms.dfns t ^"\n" ^
  2833:               "The types must be the same!"
  2834:             )
  2835:           | None -> raise Not_found
  2836:         )
  2837:         ls''
  2838:       ),
  2839:       t''
  2840:       with Not_found ->
  2841:         clierr sr
  2842:          (
  2843:          "Record coercion dst requires subset of fields of src:\n" ^
  2844:          sbe syms.dfns x' ^ " has type " ^ sbt syms.dfns t' ^
  2845:         "\nwhereas annotation requires " ^ sbt syms.dfns t''
  2846:         )
  2847:       end
  2848: 
  2849:     | `BTYP_lvalue(`BTYP_variant lhs),`BTYP_variant rhs
  2850:     | `BTYP_variant lhs,`BTYP_variant rhs ->
  2851:       begin
  2852:       try
  2853:         iter
  2854:         (fun (s,t)->
  2855:           match list_assoc_index rhs s with
  2856:           | Some j ->
  2857:             let tt = assoc s rhs in
  2858:             if not (type_eq syms.dfns t tt) then
  2859:             clierr sr (
  2860:               "Source Variant field '" ^ s ^ "' has type:\n" ^
  2861:               sbt syms.dfns t ^ "\n" ^
  2862:               "but coercion target has the different type:\n" ^
  2863:               sbt syms.dfns tt ^"\n" ^
  2864:               "The types must be the same!"
  2865:             )
  2866:           | None -> raise Not_found
  2867:         )
  2868:         lhs
  2869:         ;
  2870:         print_endline ("Coercion of variant to type " ^ sbt syms.dfns t'');
  2871:         `BEXPR_coerce (x',t''),t''
  2872:       with Not_found ->
  2873:         clierr sr
  2874:          (
  2875:          "Variant coercion src requires subset of fields of dst:\n" ^
  2876:          sbe syms.dfns x' ^ " has type " ^ sbt syms.dfns t' ^
  2877:         "\nwhereas annotation requires " ^ sbt syms.dfns t''
  2878:         )
  2879:       end
  2880:     | _ ->
  2881:       clierr sr
  2882:       (
  2883:         "Wrong type in coercion:\n" ^
  2884:         sbe syms.dfns x' ^ " has type " ^ sbt syms.dfns t' ^
  2885:         "\nwhereas annotation requires " ^ sbt syms.dfns t''
  2886:       )
  2887:     end
  2888: 
  2889:   | `AST_get_n (sr,(n,e')) ->
  2890:     let expr,typ = be e' in
  2891:     let ctyp = match unfold syms.dfns typ with
  2892:     | `BTYP_array (t,`BTYP_unitsum len)  ->
  2893:       if n<0 or n>len-1
  2894:       then clierr sr
  2895:         (
  2896:           "[bind_expression] Tuple index " ^
  2897:           string_of_int n ^
  2898:           " out of range 0.." ^
  2899:           string_of_int (len-1)
  2900:         )
  2901:       else t
  2902: 
  2903:     | `BTYP_lvalue (`BTYP_array (t,`BTYP_unitsum len)) ->
  2904:       if n<0 or n>len-1
  2905:       then clierr sr
  2906:         (
  2907:           "[bind_expression] Tuple index " ^
  2908:           string_of_int n ^
  2909:           " out of range 0.." ^
  2910:           string_of_int (len-1)
  2911:         )
  2912:       else lvalify t
  2913: 
  2914: 
  2915:     | `BTYP_tuple ts
  2916:     | `BTYP_lvalue (`BTYP_tuple ts)
  2917:       ->
  2918:       let len = length ts in
  2919:       if n<0 or n>len-1
  2920:       then clierr sr
  2921:         (
  2922:           "[bind_expression] Tuple index " ^
  2923:           string_of_int n ^
  2924:           " out of range 0.." ^
  2925:           string_of_int (len-1)
  2926:         )
  2927:       else nth ts n
  2928:     | _ ->
  2929:       clierr sr
  2930:       (
  2931:         "[bind_expression] Expected tuple " ^
  2932:         string_of_expr e' ^
  2933:         " to have tuple type, got " ^
  2934:         sbt syms.dfns typ
  2935:       )
  2936:     in
  2937:       `BEXPR_get_n (n, (expr,typ)), ctyp
  2938: 
  2939:   | `AST_get_named_variable (sr,(name,e')) ->
  2940:     let e'',t'' as x2 = be e' in
  2941:     begin match t'' with
  2942:     | `BTYP_record es
  2943:     | `BTYP_lvalue (`BTYP_record es) ->
  2944:       let rcmp (s1,_) (s2,_) = compare s1 s2 in
  2945:       let es = sort rcmp es in
  2946:       let field_name = name in
  2947:       begin match list_index (map fst es) field_name with
  2948:       | Some n -> `BEXPR_get_n (n,x2),assoc field_name es
  2949:       | None -> clierr sr
  2950:          (
  2951:            "Field " ^ field_name ^
  2952:            " is not a member of anonymous structure " ^
  2953:            sbt syms.dfns t''
  2954:           )
  2955:       end
  2956: 
  2957:     | `BTYP_inst (i,ts)
  2958:     | `BTYP_lvalue (`BTYP_inst (i,ts)) ->
  2959:       begin match Hashtbl.find syms.dfns i with
  2960:       | {pubmap=pubtab; symdef = `SYMDEF_class } ->
  2961:         (*
  2962:         print_endline "AST_get_named finds a class .. ";
  2963:         print_endline ("Looking for component named " ^ name);
  2964:         *)
  2965:         let entryset =
  2966:           try Hashtbl.find pubtab name
  2967:           with Not_found -> clierr sr ("Cannot find component " ^ name ^ " in class")
  2968:         in
  2969:         begin match entryset with
  2970:         | NonFunctionEntry idx ->
  2971:           let vtype =
  2972:             inner_typeofindex_with_ts syms sr
  2973:             { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist; depth = rs.depth+1 }
  2974:             idx ts
  2975:            in
  2976:            (*
  2977:            print_endline ("Class member variable has type " ^ sbt syms.dfns vtype);
  2978:            *)
  2979:            `BEXPR_get_named (idx,(e'',t'')),vtype
  2980:         | _ -> clierr sr ("Expected component "^name^" to be a variable")
  2981:         end
  2982:       | _ -> clierr sr ("[bind_expression] Projection requires class")
  2983:       end
  2984:     | _ -> clierr sr ("[bind_expression] Projection requires class instance")
  2985:     end
  2986: 
  2987:   | `AST_get_named_method (sr,(meth_name,meth_idx,meth_ts,obj)) ->
  2988:     (*
  2989:     print_endline ("Get named method " ^ meth_name);
  2990:     *)
  2991:     let meth_ts = map (bt sr) meth_ts in
  2992:     let oe,ot = be obj in
  2993:     begin match ot with
  2994:     | `BTYP_inst (oi,ots)
  2995:     | `BTYP_lvalue (`BTYP_inst (oi,ots)) ->
  2996: 
  2997:       (*
  2998:       (* bind the method signature in the context of the object *)
  2999:       let sign =
  3000:         let entry = Hashtbl.find syms.dfns oi in
  3001:         match entry with | {vs = vs } ->
  3002:         let bvs = map (fun (n,i,_) -> n,`BTYP_var (i,`BTYP_type)) vs in
  3003:         print_endline ("Binding sign = " ^ string_of_typecode sign);
  3004:         let env' = build_env syms (Some oi) in
  3005:         bind_type' syms env' rsground sr sign bvs
  3006:       in
  3007:       print_endline ("Got sign bound = " ^ sbt syms.dfns sign);
  3008:       *)
  3009:       begin match Hashtbl.find syms.dfns oi with
  3010:       | {id=classname; pubmap=pubtab; vs=obj_vs; symdef = `SYMDEF_class } ->
  3011:         (*
  3012:         print_endline ("AST_get_named finds a class .. " ^ classname);
  3013:         print_endline ("Looking for component named " ^ name);
  3014:         *)
  3015:         let entryset =
  3016:           try Hashtbl.find pubtab meth_name
  3017:           with Not_found -> clierr sr ("Cannot find component " ^ meth_name ^ " in class " ^ classname)
  3018:         in
  3019:         begin match entryset with
  3020:         | FunctionEntry fs ->
  3021:           if not (mem meth_idx fs) then syserr sr "Woops, method index isn't a member function!";
  3022:           begin match Hashtbl.find syms.dfns meth_idx with
  3023:           | {id=method_name; vs=meth_vs; symdef = `SYMDEF_function _} ->
  3024:             assert (meth_name = method_name);
  3025:             (*
  3026:             print_endline ("Found " ^ si (length fs) ^ " candidates");
  3027:             print_endline ("Object ts=" ^ catmap "," (sbt syms.dfns) ots);
  3028:             print_endline ("Object vs = " ^ print_ivs_with_index obj_vs);
  3029:             print_endline ("Method ts=" ^ catmap "," (sbt syms.dfns) meth_ts);
  3030:             print_endline ("Method vs = " ^ print_ivs_with_index meth_vs);
  3031:             *)
  3032:             (*
  3033:             begin match resolve_overload' syms rs sr fs meth_name [sign] meth_ts with
  3034:             | Some (meth_idx,meth_rt,mgu,meth_ts) ->
  3035:               (*
  3036:               print_endline "Overload resolution OK";
  3037:               *)
  3038:               (* Now we need to fixate the class type variables in the method *)
  3039:               *)
  3040:               (*
  3041:               print_endline ("ots = " ^ catmap "," (sbt syms.dfns) ots);
  3042:               *)
  3043:               let omap =
  3044:                 let vars = map2 (fun (_,i,_) t -> i,t) obj_vs ots in
  3045:                 hashtable_of_list vars
  3046:               in
  3047:               let meth_ts = map (varmap_subst omap) meth_ts in
  3048:               (*
  3049:               print_endline ("meth_ts = " ^ catmap "," (sbt syms.dfns) meth_ts);
  3050:               *)
  3051:               let ts = ots @ meth_ts in
  3052:               let typ = typeofindex_with_ts syms sr meth_idx ts in
  3053:               `BEXPR_method_closure ((oe,ot),meth_idx,ts),typ
  3054: 
  3055: 
  3056:             (*
  3057:             | _ -> clierr sr
  3058:               ("[get_named_method] Cannot find method " ^ meth_name ^
  3059:                 " with signature "^sbt syms.dfns sign^" in class, candidates are:\n" ^
  3060:                 catmap "," (fun i -> meth_name ^ "<" ^si i^ ">") fs
  3061:               )
  3062:           end
  3063:           *)
  3064:           | _ -> clierr sr ("[get_named_method] Can't find method "^meth_name)
  3065:           end
  3066:         | _ -> clierr sr ("Expected component "^meth_name^" to be a function")
  3067:         end
  3068:       | _ -> clierr sr ("[bind_expression] Projection requires class")
  3069:       end
  3070:     | _ -> clierr sr ("[bind_expression] Projection requires class instance")
  3071:     end
  3072: 
  3073:   | `AST_case_index (sr,e) ->
  3074:     let (e',t) as e  = be e in
  3075:     begin match lstrip syms.dfns t with
  3076:     | `BTYP_unitsum _ -> ()
  3077:     | `BTYP_sum _ -> ()
  3078:     | `BTYP_variant _ -> ()
  3079:     | `BTYP_inst (i,_) ->
  3080:       begin match Hashtbl.find syms.dfns i with
  3081:       | {symdef=`SYMDEF_union _} -> ()
  3082:       | {id=id} -> clierr sr ("Argument of caseno must be sum or union type, got type " ^ id)
  3083:       end
  3084:     | _ -> clierr sr ("Argument of caseno must be sum or union type, got " ^ sbt syms.dfns t)
  3085:     end
  3086:     ;
  3087:     let int_t = bt sr (`AST_name (sr,"int",[])) in
  3088:     begin match e' with
  3089:     | `BEXPR_case (i,_) ->
  3090:       `BEXPR_literal (`AST_int ("int",Big_int.big_int_of_int i))
  3091:     | _ -> `BEXPR_case_index e
  3092:     end
  3093:     ,
  3094:     int_t
  3095: 
  3096:   | `AST_case_tag (sr,v) ->
  3097:      clierr sr "plain case tag not allowed in expression (only in pattern)"
  3098: 
  3099:   | `AST_variant (sr,(s,e)) ->
  3100:     let (_,t) as e = be e in
  3101:     `BEXPR_variant (s,e),`BTYP_variant [s,t]
  3102: 
  3103:   | `AST_typed_case (sr,v,t) ->
  3104:     let t = bt sr t in
  3105:     ignore (try unfold syms.dfns t with _ -> failwith "AST_typed_case unfold screwd");
  3106:     begin match unfold syms.dfns t with
  3107:     | `BTYP_unitsum k ->
  3108:       if v<0 or v>= k
  3109:       then clierr sr "Case index out of range of sum"
  3110:       else
  3111:         `BEXPR_case (v,t),t  (* const ctor *)
  3112: 
  3113:     | `BTYP_sum ls ->
  3114:       if v<0 or v>= length ls
  3115:       then clierr sr "Case index out of range of sum"
  3116:       else let vt = nth ls v in
  3117:       let ct =
  3118:         match vt with
  3119:         | `BTYP_tuple [] -> t        (* const ctor *)
  3120:         | _ -> `BTYP_function (vt,t) (* non-const ctor *)
  3121:       in
  3122:       `BEXPR_case (v,t), ct
  3123:     | _ ->
  3124:       clierr sr
  3125:       (
  3126:         "[bind_expression] Type of case must be sum, got " ^
  3127:         sbt syms.dfns t
  3128:       )
  3129:     end
  3130: 
  3131:   | `AST_name (sr,name,ts) ->
  3132:     (*
  3133:     print_endline ("BINDING NAME " ^ name);
  3134:     *)
  3135:     let ts = map (bt sr) ts in
  3136:     begin match inner_lookup_name_in_env syms env rs sr name with
  3137:     | NonFunctionEntry (index) ->
  3138:       let ts = adjust_ts syms sr index ts in
  3139:       `BEXPR_name (index,ts),
  3140:       let t = ti sr index ts in
  3141:       t
  3142: 
  3143:     | FunctionEntry fs ->
  3144:       assert (length fs > 0);
  3145:       begin match args with
  3146:       | [] ->
  3147:         clierr sr
  3148:         (
  3149:           "[bind_expression] Simple name " ^ name ^
  3150:           " binds to function set in\n" ^
  3151:           short_string_of_src sr
  3152:         )
  3153:       | args ->
  3154:         let sufs = map snd args in
  3155:         let rs = { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist } in
  3156:         let ro = resolve_overload' syms rs sr fs name sufs ts in
  3157:         begin match ro with
  3158:          | Some (index, ret,mgu,ts) ->
  3159:            (*
  3160:            print_endline "OK, overload resolved!!";
  3161:            *)
  3162:            `BEXPR_closure (index,ts),
  3163:             ti sr index ts
  3164:             (*
  3165:             typeofindex_with_ts syms sr index ts
  3166:             *)
  3167: 
  3168:          | None -> clierr sr "Cannot resolve overload .."
  3169:         end
  3170:       end
  3171:     end
  3172: 
  3173:   | `AST_index (_,name,index) ->
  3174:     let ts = adjust_ts syms sr index [] in
  3175:     let t = ti sr index ts in
  3176:     begin match Hashtbl.find syms.dfns index with
  3177:     | {symdef=`SYMDEF_fun _ }
  3178:     | {symdef=`SYMDEF_function _ }
  3179:     ->
  3180:     (*
  3181:     print_endline ("Indexed name: Binding " ^ name ^ "<"^si index^">"^ " to closure");
  3182:     *)
  3183:       `BEXPR_closure (index,ts),t
  3184:     | _ ->
  3185:     (*
  3186:     print_endline ("Indexed name: Binding " ^ name ^ "<"^si index^">"^ " to variable");
  3187:     *)
  3188:       `BEXPR_name (index,ts),t
  3189:     end
  3190: 
  3191:   | `AST_the(_,`AST_name (sr,name,ts)) ->
  3192:     (*
  3193:     print_endline ("AST_name " ^ name ^ "[" ^ catmap "," string_of_typecode ts^ "]");
  3194:     *)
  3195:     let ts = map (bt sr) ts in
  3196:     begin match inner_lookup_name_in_env syms env rs sr name with
  3197:     | NonFunctionEntry (index) ->
  3198:       let ts = adjust_ts syms sr index ts in
  3199:       `BEXPR_name (index,ts),
  3200:       let t = ti sr index ts in
  3201:       t
  3202: 
  3203:     | FunctionEntry [index] ->
  3204:       let ts = adjust_ts syms sr index ts in
  3205:       `BEXPR_closure (index,ts),
  3206:       let t = ti sr index ts in
  3207:       t
  3208: 
  3209:     | FunctionEntry _ ->
  3210:       clierr sr
  3211:       (
  3212:         "[bind_expression] Simple 'the' name " ^ name ^
  3213:         " binds to non-singleton function set"
  3214:       )
  3215:     end
  3216:   | `AST_the (sr,q) -> clierr sr "invalid use of 'the' "
  3217: 
  3218:   | (`AST_lookup (sr,(e,name,ts))) as qn ->
  3219:     (*
  3220:     print_endline ("Handling qn " ^ string_of_qualified_name qn);
  3221:     *)
  3222:     let ts = map (bt sr) ts in
  3223:     let entry =
  3224:       match
  3225:           eval_module_expr
  3226:           syms
  3227:           env
  3228:           e
  3229:       with
  3230:       | (Simple_module (impl, ts, htab,dirs)) ->
  3231:         let env' = mk_bare_env syms impl in
  3232:         let tables = get_pub_tables syms env' rs dirs in
  3233:         let result = lookup_name_in_table_dirs htab tables sr name in
  3234:         result
  3235: 
  3236:     in
  3237:       begin match entry with
  3238:       | Some entry ->
  3239:         begin match entry with
  3240:         | NonFunctionEntry (i) ->
  3241:           begin match Hashtbl.find syms.dfns i with
  3242:           | {sr=srn; symdef=`SYMDEF_inherit qn} -> be (qn :> expr_t)
  3243:           | _ ->
  3244:             let ts = adjust_ts syms sr i ts in
  3245:             `BEXPR_name (i,ts),
  3246:             ti sr i ts
  3247:           end
  3248: 
  3249:         | FunctionEntry fs ->
  3250:           begin match args with
  3251:           | [] ->
  3252:             clierr sr
  3253:             (
  3254:               "[bind_expression] Qualified name " ^
  3255:               string_of_qualified_name qn ^
  3256:               " binds to function set"
  3257:             )
  3258: 
  3259:           | args ->
  3260:             let sufs = map snd args in
  3261:             let rs  = { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist } in
  3262:             let ro = resolve_overload' syms rs sr fs name sufs ts in
  3263:             begin match ro with
  3264:              | Some (index, ret,mgu,ts) ->
  3265:                (*
  3266:                print_endline "OK, overload resolved!!";
  3267:                *)
  3268:                `BEXPR_closure (index,ts),
  3269:                (*
  3270:                typeofindex_with_ts syms sr index ts
  3271:                *)
  3272:                ti sr index ts
  3273: 
  3274:             | None ->
  3275:               clierr sr "Overload resolution failed .. "
  3276:             end
  3277:           end
  3278:         end
  3279: 
  3280:       | None ->
  3281:         clierr sr
  3282:         (
  3283:           "Can't find " ^ name
  3284:         )
  3285:       end
  3286: 
  3287:   | `AST_suffix (sr,(f,suf)) ->
  3288:     let sign = bt sr suf in
  3289:     begin match (f:>expr_t) with
  3290:     | #qualified_name_t as name ->
  3291:       let srn = src_of_expr name in
  3292:       lookup_qn_with_sig'
  3293:         syms
  3294:         sr srn env
  3295:         { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist }
  3296:         name [sign]
  3297: 
  3298:     | e -> be e
  3299:     end
  3300: 
  3301:     (*
  3302:     lookup sr (f:>expr_t) [sign]
  3303:     *)
  3304: 
  3305:   | `AST_ref (_,(`AST_deref (sr,e))) -> be e
  3306: 
  3307:   | `AST_lvalue (srr,e) ->
  3308:     failwith "WOOPS, lvalue in expression??";
  3309: 
  3310:   | `AST_ref (sr,(`AST_dot (_,(e,id,[])))) ->
  3311:     let ref_name = "ref_" ^ id in
  3312:     be
  3313:     (
  3314:       `AST_apply
  3315:       (
  3316:         sr,
  3317:         (
  3318:           `AST_name (sr, ref_name,[]),
  3319:           `AST_ref (sr,e)
  3320:         )
  3321:       )
  3322:     )
  3323: 
  3324:   | `AST_ref (srr,e) ->
  3325:     let e',t' = be e in
  3326:     begin match e' with
  3327:     | `BEXPR_name (index,ts) ->
  3328:       begin match get_data syms.dfns index with
  3329:       {id=id; sr=sr; symdef=entry} ->
  3330:       begin match entry with
  3331:       | `SYMDEF_inherit _ -> clierr srr "Woops, bindexpr yielded inherit"
  3332:       | `SYMDEF_inherit_fun _ -> clierr srr "Woops, bindexpr yielded inherit fun"
  3333:       | `SYMDEF_var _ ->
  3334:         let vtype =
  3335:           inner_typeofindex_with_ts syms sr
  3336:           { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist; depth = rs.depth+1 }
  3337:          index ts
  3338:         in
  3339:           `BEXPR_ref (index,ts), `BTYP_pointer vtype
  3340: 
  3341:       | `SYMDEF_parameter _ ->
  3342:          clierr2 srr sr
  3343:         (
  3344:           "[bind_expression] " ^
  3345:           "Address value parameter " ^ id
  3346:         )
  3347:       | `SYMDEF_const _
  3348:       | `SYMDEF_val _ ->
  3349:         clierr2 srr sr
  3350:         (
  3351:           "[bind_expression] " ^
  3352:           "Can't address a value or const " ^ id
  3353:         )
  3354:       | _ ->
  3355:          clierr2 srr sr
  3356:         (
  3357:           "[bind_expression] " ^
  3358:           "Address non variable " ^ id
  3359:         )
  3360:       end
  3361:       end
  3362:     | _ ->
  3363:        clierr srr
  3364:         (
  3365:           "[bind_expression] " ^
  3366:           "Address non variable"
  3367:         )
  3368:     end
  3369: 
  3370:   | `AST_deref (_,`AST_ref (sr,e)) ->
  3371:     let e,t = be e in
  3372:     let t = lvalify t in e,t
  3373: 
  3374:   | `AST_deref (sr,e) ->
  3375:     let e,t = be e in
  3376:     begin match unfold syms.dfns t with
  3377:     | `BTYP_lvalue (`BTYP_pointer t')
  3378:     | `BTYP_pointer t'
  3379:       -> `BEXPR_deref (e,t),`BTYP_lvalue t'
  3380:     | _ -> clierr sr "[bind_expression'] Dereference non pointer"
  3381:     end
  3382: 
  3383:   | `AST_literal (sr,v) ->
  3384:     let t = typeof_literal syms env sr v in
  3385:     `BEXPR_literal v, t
  3386: 
  3387:   | `AST_method_apply (sra,(fn,e2,meth_ts)) ->
  3388:     (*
  3389:     print_endline ("METHOD APPLY: " ^ string_of_expr e);
  3390:     *)
  3391:     (* .. PRAPS .. *)
  3392:     let meth_ts = map (bt sra) meth_ts in
  3393:     let (be2,t2) as x2 = be e2 in
  3394:     begin match t2 with
  3395:     | `BTYP_lvalue(`BTYP_record es)
  3396:     | `BTYP_record es ->
  3397:       let rcmp (s1,_) (s2,_) = compare s1 s2 in
  3398:       let es = sort rcmp es in
  3399:       let field_name = String.sub fn 4 (String.length fn -4) in
  3400:       begin match list_index (map fst es) field_name with
  3401:       | Some n -> `BEXPR_get_n (n,x2),assoc field_name es
  3402:       | None -> clierr sr
  3403:          (
  3404:            "Field " ^ field_name ^
  3405:            " is not a member of anonymous structure " ^
  3406:            sbt syms.dfns t2
  3407:           )
  3408:       end
  3409:     | _ ->
  3410:     let tbe1 =
  3411:       match t2 with
  3412:       | `BTYP_lvalue(`BTYP_inst (index,ts))
  3413:       | `BTYP_inst (index,ts) ->
  3414:         begin match get_data syms.dfns index with
  3415:         {id=id; parent=parent;sr=sr;symdef=entry} ->
  3416:         match parent with
  3417:         | None -> clierr sra "Koenig lookup: No parent for method apply (can't handle global yet)"
  3418:         | Some index' ->
  3419:           match get_data syms.dfns index' with
  3420:           {id=id';sr=sr';parent=parent';vs=vs';pubmap=name_map;dirs=dirs;symdef=entry'}
  3421:           ->
  3422:           match entry' with
  3423:           | `SYMDEF_module
  3424:           | `SYMDEF_function _
  3425:             ->
  3426:             koenig_lookup syms rs sra id' name_map fn t2 (ts @ meth_ts)
  3427: 
  3428:           | _ -> clierr sra ("Koenig lookup: parent for method apply not module")
  3429:         end
  3430: 
  3431:       | _ -> clierr sra ("apply method "^fn^" to nongenerative type")
  3432:     in
  3433:       cal_apply syms sra tbe1 (be2, t2)
  3434:     end
  3435: 
  3436:   | `AST_map (sr,f,a) ->
  3437:     handle_map sr (be f) (be a)
  3438: 
  3439:   | `AST_apply (sr,(f',a')) ->
  3440:     (*
  3441:     print_endline ("Apply " ^ string_of_expr f' ^ " to " ^  string_of_expr a');
  3442:     *)
  3443:     let (ea,ta) as a = be a' in
  3444:     (*
  3445:     print_endline ("Recursive descent into application " ^ string_of_expr e);
  3446:     *)
  3447:     let (bf,tf) as f  =
  3448:       match f' with
  3449:       | #qualified_name_t as name ->
  3450:         let sigs = map snd args in
  3451:         let srn = src_of_expr name in
  3452:         lookup_qn_with_sig' syms sr srn env
  3453:           { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist }
  3454:           name (ta::sigs)
  3455:       | _ -> bind_expression' syms env rs f' (a :: args)
  3456:     in
  3457:     begin match tf with
  3458:     | `BTYP_cfunction _ -> cal_apply syms sr f a
  3459:     | `BTYP_function _ -> cal_apply syms sr f a
  3460:     | _ ->
  3461:       let apl name =
  3462:         be
  3463:         (
  3464:           `AST_apply
  3465:           (
  3466:             sr,
  3467:             (
  3468:               `AST_name (sr,name,[]),
  3469:               `AST_tuple (sr,[f';a'])
  3470:             )
  3471:           )
  3472:         )
  3473:       in
  3474:       apl "apply"
  3475:     end
  3476: 
  3477: 
  3478:   | `AST_arrayof (sr,es) ->
  3479:     let bets = map be es in
  3480:     let _, bts = split bets in
  3481:     let n = length bets in
  3482:     if n > 1 then begin
  3483:       let t = hd bts in
  3484:       iter
  3485:       (fun t' -> if t <> t' then
  3486:          clierr sr
  3487:          (
  3488:            "Elements of this array must all be of type:\n" ^
  3489:            sbt syms.dfns t ^ "\ngot:\n"^ sbt syms.dfns t'
  3490:          )
  3491:       )
  3492:       (tl bts)
  3493:       ;
  3494:       let t = `BTYP_array (t,`BTYP_unitsum n) in
  3495:       `BEXPR_tuple bets,t
  3496:     end else if n = 1 then hd bets
  3497:     else syserr sr "Empty array?"
  3498: 
  3499:   | `AST_record_type _ -> assert false
  3500:   | `AST_variant_type _ -> assert false
  3501: 
  3502:   | `AST_record (sr,ls) ->
  3503:     begin match ls with
  3504:     | [] -> `BEXPR_tuple [],`BTYP_tuple []
  3505:     | _ ->
  3506:     let ss,es = split ls in
  3507:     let es = map be es in
  3508:     let ts = map snd es in
  3509:     let t = `BTYP_record (combine ss ts) in
  3510:     `BEXPR_record (combine ss es),t
  3511:     end
  3512: 
  3513:   | `AST_tuple (_,es) ->
  3514:     let bets = map be es in
  3515:     let _, bts = split bets in
  3516:     let n = length bets in
  3517:     if n > 1 then
  3518:       try
  3519:         let t = hd bts in
  3520:         iter
  3521:         (fun t' -> if t <> t' then raise Not_found)
  3522:         (tl bts)
  3523:         ;
  3524:         let t = `BTYP_array (t,`BTYP_unitsum n) in
  3525:         `BEXPR_tuple bets,t
  3526:       with Not_found ->
  3527:         `BEXPR_tuple bets, `BTYP_tuple bts
  3528:     else if n = 1 then
  3529:       hd bets
  3530:     else
  3531:     `BEXPR_tuple [],`BTYP_tuple []
  3532: 
  3533: 
  3534:   | `AST_dot (sr,(e,name,ts)) ->
  3535:     let (_,tt') as te = be e in (* polymorphic! *)
  3536:     let is_lvalue = match tt' with
  3537:       | `BTYP_lvalue _ -> true
  3538:       | _ -> false
  3539:     in
  3540:     let lmap t = if is_lvalue then `BTYP_lvalue t else t in
  3541:     let tt' = rt tt' in
  3542:     begin match tt' with
  3543:     | `BTYP_inst (i,ts') ->
  3544:       begin match Hashtbl.find syms.dfns i with
  3545:       | {id=id; vs=vs; symdef=`SYMDEF_struct ls } ->
  3546:         let cidx,ct =
  3547:           let rec scan i = function
  3548:           | [] -> failwith "Can't find struct component"
  3549:           | (vn,vat)::_ when vn = name -> i,vat
  3550:           | _:: t -> scan (i+1) t
  3551:           in scan 0 ls
  3552:         in
  3553:         let ct =
  3554:           let bvs = map (fun (n,i,_) -> n,`BTYP_var (i,`BTYP_type)) vs in
  3555:           let env' = build_env syms (Some i) in
  3556:           bind_type' syms env' rsground sr ct bvs
  3557:         in
  3558:         let vs' = map (fun (s,i,tp) -> s,i) vs in
  3559:         let ct = tsubst vs' ts' ct in
  3560:         (* propagate lvalueness to struct component *)
  3561:         `BEXPR_get_n (cidx,te),lmap ct
  3562: 
  3563:       | {id=id; vs=vs; symdef=`SYMDEF_cstruct ls } ->
  3564:         (* NOTE: we try $1.name binding using get_n first,
  3565:         but if we can't find a component we treat the
  3566:         entity as abstract.
  3567: 
  3568:         Hmm not sure that cstructs can be polymorphic.
  3569:         *)
  3570:         begin try
  3571:           let cidx,ct =
  3572:             let rec scan i = function
  3573:             | [] -> raise Not_found
  3574:             | (vn,vat)::_ when vn = name -> i,vat
  3575:             | _:: t -> scan (i+1) t
  3576:             in scan 0 ls
  3577:           in
  3578:           let ct =
  3579:             let bvs = map (fun (n,i,_) -> n,`BTYP_var (i,`BTYP_type)) vs in
  3580:             let env' = build_env syms (Some i) in
  3581:             bind_type' syms env' rsground sr ct bvs
  3582:           in
  3583:           let vs' = map (fun (s,i,tp) -> s,i) vs in
  3584:           let ct = tsubst vs' ts' ct in
  3585:           (* propagate lvalueness to struct component *)
  3586:           `BEXPR_get_n (cidx,te),lmap ct
  3587:         with
  3588:         | Not_found ->
  3589:           let get_name = "get_" ^ name in
  3590:           be (`AST_method_apply (sr,(get_name,e,ts)))
  3591:         end
  3592: 
  3593:       | {id=id; pubmap=pubtab; symdef = `SYMDEF_class } ->
  3594:         (*
  3595:         print_endline "AST_get_named finds a class .. ";
  3596:         print_endline ("Looking for component named " ^ name);
  3597:         *)
  3598:         let entryset =
  3599:           try Hashtbl.find pubtab name
  3600:           with Not_found -> clierr sr ("Cannot find component " ^ name ^ " in class")
  3601:         in
  3602:         begin match entryset with
  3603:         | NonFunctionEntry idx ->
  3604:           let vtype =
  3605:             inner_typeofindex_with_ts syms sr
  3606:             { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist; depth = rs.depth+1 }
  3607:             idx ts'
  3608:            in
  3609:            (*
  3610:            print_endline ("Class member variable has type " ^ sbt syms.dfns vtype);
  3611:            *)
  3612:            `BEXPR_get_named (idx,te),vtype
  3613:         | FunctionEntry _ ->
  3614:           (* WEAK! *)
  3615:           let get_name = "get_" ^ name in
  3616:           be (`AST_method_apply (sr,(get_name,e,ts)))
  3617: 
  3618:         end
  3619: 
  3620:       | {id=id; symdef=`SYMDEF_cclass _} ->
  3621:         let get_name = "get_" ^ name in
  3622:         be (`AST_method_apply (sr,(get_name,e,ts)))
  3623: 
  3624:       (* abstract type binding *)
  3625:       | {id=id; symdef=`SYMDEF_abs _ } ->
  3626:         let get_name = "get_" ^ name in
  3627:         be (`AST_method_apply (sr,(get_name,e,ts)))
  3628: 
  3629:       | _ ->
  3630:         failwith ("operator . Expected nominal type to be"^
  3631:         " struct, cstruct or abstract primitive, got " ^
  3632:         sbt syms.dfns tt')
  3633: 
  3634:       end
  3635: 
  3636:     | `BTYP_record es ->
  3637:       let rcmp (s1,_) (s2,_) = compare s1 s2 in
  3638:       let es = sort rcmp es in
  3639:       let field_name = name in
  3640:       begin match list_index (map fst es) field_name with
  3641:       | Some n -> `BEXPR_get_n (n,te),lmap (assoc field_name es)
  3642:       | None -> clierr sr
  3643:          (
  3644:            "Field " ^ field_name ^
  3645:            " is not a member of anonymous structure type " ^
  3646:            sbt syms.dfns tt'
  3647:           )
  3648:       end
  3649: 
  3650:     | `BTYP_tuple _ ->
  3651:       failwith ("Expected nominal type! Got tuple ! " ^ sbt syms.dfns tt')
  3652: 
  3653:     | _ -> failwith ("Expected nominal type! Got " ^ sbt syms.dfns tt')
  3654:     end
  3655: 
  3656: 
  3657:   | `AST_match_case (sr,(v,e)) ->
  3658:      `BEXPR_match_case (v,be e),flx_bbool
  3659: 
  3660:   | `AST_match_ctor (sr,(qn,e)) ->
  3661:     begin match qn with
  3662:     | `AST_name (sr,name,ts) ->
  3663:       (*
  3664:       print_endline ("WARNING(deprecate): match constructor by name! " ^ name);
  3665:       *)
  3666:       let (_,ut) as ue = be e in
  3667:       let ut = rt ut in
  3668:       (*
  3669:       print_endline ("Union type is " ^ sbt syms.dfns ut);
  3670:       *)
  3671:       begin match ut with
  3672:       | `BTYP_inst (i,ts') ->
  3673:         (*
  3674:         print_endline ("OK got type " ^ si i);
  3675:         *)
  3676:         begin match Hashtbl.find syms.dfns i with
  3677:         | {id=id; symdef=`SYMDEF_union ls } ->
  3678:           (*
  3679:           print_endline ("UNION TYPE! " ^ id);
  3680:           *)
  3681:           let vidx =
  3682:             let rec scan = function
  3683:             | [] -> failwith "Can't find union variant"
  3684:             | (vn,vidx,vat)::_ when vn = name -> vidx
  3685:             | _:: t -> scan t
  3686:             in scan ls
  3687:           in
  3688:           (*
  3689:           print_endline ("Index is " ^ si vidx);
  3690:           *)
  3691:           `BEXPR_match_case (vidx,ue),flx_bbool
  3692: 
  3693:         (* this handles the case of a C type we want to model
  3694:         as a union by provding _match_ctor_name style function
  3695:         as C primitives ..
  3696:         *)
  3697:         | {id=id; symdef=`SYMDEF_abs _ } ->
  3698:           let fname = `AST_name (sr,"_match_ctor_" ^ name,ts) in
  3699:           be (`AST_apply ( sr, (fname,e)))
  3700: 
  3701:         | _ -> failwith "Woooops expected union or abstract"
  3702:         end
  3703:       | _ -> failwith "Woops, expected nominal type"
  3704:       end
  3705: 
  3706:     | `AST_lookup (sr,(context,name,ts)) ->
  3707:       (*
  3708:       print_endline ("WARNING(deprecate): match constructor by name! " ^ name);
  3709:       *)
  3710:       let (_,ut) as ue = be e in
  3711:       let ut = rt ut in
  3712:       (*
  3713:       print_endline ("Union type is " ^ sbt syms.dfns ut);
  3714:       *)
  3715:       begin match ut with
  3716:       | `BTYP_inst (i,ts') ->
  3717:         (*
  3718:         print_endline ("OK got type " ^ si i);
  3719:         *)
  3720:         begin match Hashtbl.find syms.dfns i with
  3721:         | {id=id; symdef=`SYMDEF_union ls } ->
  3722:           (*
  3723:           print_endline ("UNION TYPE! " ^ id);
  3724:           *)
  3725:           let vidx =
  3726:             let rec scan = function
  3727:             | [] -> failwith "Can't find union variant"
  3728:             | (vn,vidx,vat)::_ when vn = name -> vidx
  3729:             | _:: t -> scan t
  3730:             in scan ls
  3731:           in
  3732:           (*
  3733:           print_endline ("Index is " ^ si vidx);
  3734:           *)
  3735:           `BEXPR_match_case (vidx,ue),flx_bbool
  3736: 
  3737:         (* this handles the case of a C type we want to model
  3738:         as a union by provding _match_ctor_name style function
  3739:         as C primitives ..
  3740:         *)
  3741:         | {id=id; symdef=`SYMDEF_abs _ } ->
  3742:           let fname = `AST_lookup (sr,(context,"_match_ctor_" ^ name,ts)) in
  3743:           be (`AST_apply ( sr, (fname,e)))
  3744:         | _ -> failwith "Woooops expected union or abstract type"
  3745:         end
  3746:       | _ -> failwith "Woops, expected nominal type"
  3747:       end
  3748: 
  3749:     | `AST_typed_case (sr,v,_)
  3750:     | `AST_case_tag (sr,v) ->
  3751:        be (`AST_match_case (sr,(v,e)))
  3752: 
  3753:     | _ -> clierr sr "Expected variant constructor name in union decoder"
  3754:     end
  3755: 
  3756:   | `AST_case_arg (sr,(v,e)) ->
  3757:      let (_,t) as e' = be e in
  3758:     ignore (try unfold syms.dfns t with _ -> failwith "AST_case_arg unfold screwd");
  3759:      begin match lstrip syms.dfns (unfold syms.dfns t) with
  3760:      | `BTYP_unitsum n ->
  3761:        if v < 0 or v >= n
  3762:        then clierr sr "Invalid sum index"
  3763:        else
  3764:          `BEXPR_case_arg (v, e'),unit_t
  3765: 
  3766:      | `BTYP_sum ls ->
  3767:        let n = length ls in
  3768:        if v<0 or v>=n
  3769:        then clierr sr "Invalid sum index"
  3770:        else let t = nth ls v in
  3771:        `BEXPR_case_arg (v, e'),t
  3772: 
  3773:      | _ -> clierr sr ("Expected sum type, got " ^ sbt syms.dfns t)
  3774:      end
  3775: 
  3776:   | `AST_ctor_arg (sr,(qn,e)) ->
  3777:     begin match qn with
  3778:     | `AST_name (sr,name,ts) ->
  3779:       (*
  3780:       print_endline ("WARNING(deprecate): decode variant by name! " ^ name);
  3781:       *)
  3782:       let (_,ut) as ue = be e in
  3783:       let ut = rt ut in
  3784:       (*
  3785:       print_endline ("Union type is " ^ sbt syms.dfns ut);
  3786:       *)
  3787:       begin match ut with
  3788:       | `BTYP_inst (i,ts') ->
  3789:         (*
  3790:         print_endline ("OK got type " ^ si i);
  3791:         *)
  3792:         begin match Hashtbl.find syms.dfns i with
  3793:         | {id=id; vs=vs; symdef=`SYMDEF_union ls } ->
  3794:           (*
  3795:           print_endline ("UNION TYPE! " ^ id);
  3796:           *)
  3797:           let vidx,vt =
  3798:             let rec scan = function
  3799:             | [] -> failwith "Can't find union variant"
  3800:             | (vn,vidx,vt)::_ when vn = name -> vidx,vt
  3801:             | _:: t -> scan t
  3802:             in scan ls
  3803:           in
  3804:           (*
  3805:           print_endline ("Index is " ^ si vidx);
  3806:           *)
  3807:           let vt =
  3808:             let bvs = map (fun (n,i,_) -> n,`BTYP_var (i,`BTYP_type)) vs in
  3809:             (*
  3810:             print_endline ("Binding ctor arg type = " ^ string_of_typecode vt);
  3811:             *)
  3812:             let env' = build_env syms (Some i) in
  3813:             bind_type' syms env' rsground sr vt bvs
  3814:           in
  3815:           (*
  3816:           print_endline ("Bound polymorphic type = " ^ sbt syms.dfns vt);
  3817:           *)
  3818:           let vs' = map (fun (s,i,tp) -> s,i) vs in
  3819:           let vt = tsubst vs' ts' vt in
  3820:           (*
  3821:           print_endline ("Instantiated type = " ^ sbt syms.dfns vt);
  3822:           *)
  3823:           `BEXPR_case_arg (vidx,ue),vt
  3824: 
  3825:         (* this handles the case of a C type we want to model
  3826:         as a union by provding _ctor_arg style function
  3827:         as C primitives ..
  3828:         *)
  3829:         | {id=id; symdef=`SYMDEF_abs _ } ->
  3830:           let fname = `AST_name (sr,"_ctor_arg_" ^ name,ts) in
  3831:           be (`AST_apply ( sr, (fname,e)))
  3832: 
  3833:         | _ -> failwith "Woooops expected union or abstract type"
  3834:         end
  3835:       | _ -> failwith "Woops, expected nominal type"
  3836:       end
  3837: 
  3838: 
  3839:     | `AST_lookup (sr,(e,name,ts)) ->
  3840:       (*
  3841:       print_endline ("WARNING(deprecate): decode variant by name! " ^ name);
  3842:       *)
  3843:       let (_,ut) as ue = be e in
  3844:       let ut = rt ut in
  3845:       (*
  3846:       print_endline ("Union type is " ^ sbt syms.dfns ut);
  3847:       *)
  3848:       begin match ut with
  3849:       | `BTYP_inst (i,ts') ->
  3850:         (*
  3851:         print_endline ("OK got type " ^ si i);
  3852:         *)
  3853:         begin match Hashtbl.find syms.dfns i with
  3854:         | {id=id; vs=vs; symdef=`SYMDEF_union ls } ->
  3855:           (*
  3856:           print_endline ("UNION TYPE! " ^ id);
  3857:           *)
  3858:           let vidx,vt =
  3859:             let rec scan = function
  3860:             | [] -> failwith "Can't find union variant"
  3861:             | (vn,vidx,vt)::_ when vn = name -> vidx,vt
  3862:             | _:: t -> scan t
  3863:             in scan ls
  3864:           in
  3865:           (*
  3866:           print_endline ("Index is " ^ si vidx);
  3867:           *)
  3868:           let vt =
  3869:             let bvs = map (fun (n,i,_) -> n,`BTYP_var (i,`BTYP_type)) vs in
  3870:             (*
  3871:             print_endline ("Binding ctor arg type = " ^ string_of_typecode vt);
  3872:             *)
  3873:             let env' = build_env syms (Some i) in
  3874:             bind_type' syms env' rsground sr vt bvs
  3875:           in
  3876:           (*
  3877:           print_endline ("Bound polymorphic type = " ^ sbt syms.dfns vt);
  3878:           *)
  3879:           let vs' = map (fun (s,i,tp) -> s,i) vs in
  3880:           let vt = tsubst vs' ts' vt in
  3881:           (*
  3882:           print_endline ("Instantiated type = " ^ sbt syms.dfns vt);
  3883:           *)
  3884:           `BEXPR_case_arg (vidx,ue),vt
  3885: 
  3886:         (* this handles the case of a C type we want to model
  3887:         as a union by provding _match_ctor_name style function
  3888:         as C primitives ..
  3889:         *)
  3890:         | {id=id; symdef=`SYMDEF_abs _ } ->
  3891:           let fname = `AST_lookup (sr,(e,"_ctor_arg_" ^ name,ts)) in
  3892:           be (`AST_apply ( sr, (fname,e)))
  3893: 
  3894:         | _ -> failwith "Woooops expected union or abstract type"
  3895:         end
  3896:       | _ -> failwith "Woops, expected nominal type"
  3897:       end
  3898: 
  3899: 
  3900:     | `AST_typed_case (sr,v,_)
  3901:     | `AST_case_tag (sr,v) ->
  3902:       be (`AST_case_arg (sr,(v,e)))
  3903: 
  3904:     | _ -> clierr sr "Expected variant constructor name in union dtor"
  3905:     end
  3906: 
  3907:   | `AST_string_regmatch (sr,_)
  3908:   | `AST_regmatch (sr,_) ->
  3909:     syserr sr
  3910:     (
  3911:       "[bind_expression] "  ^
  3912:       "Unexpected regmatch when binding expression (should have been lifted out)" ^
  3913:       string_of_expr e
  3914:     )
  3915: 
  3916:   | `AST_reglex (sr,(p1,p2,cls)) ->
  3917:     syserr sr
  3918:     (
  3919:       "[bind_expression] " ^
  3920:       "Unexpected reglex when binding expression (should have been lifted out)" ^
  3921:       string_of_expr e
  3922:     )
  3923: 
  3924:   | `AST_lambda (sr,_) ->
  3925:     syserr sr
  3926:     (
  3927:       "[bind_expression] " ^
  3928:       "Unexpected lambda when binding expression (should have been lifted out)" ^
  3929:       string_of_expr e
  3930:     )
  3931: 
  3932:   | `AST_match (sr,_) ->
  3933:     clierr sr
  3934:     (
  3935:       "[bind_expression] " ^
  3936:       "Unexpected match when binding expression (should have been lifted out)"
  3937:     )
  3938: 
  3939: and resolve_overload
  3940:   syms
  3941:   sr
  3942:   (fs : entry_kind_t list)
  3943:   (name: string)
  3944:   (sufs : btypecode_t list)
  3945:   (ts:btypecode_t list)
  3946: =
  3947:   resolve_overload' syms rsground sr fs name sufs ts
  3948: 
  3949: and resolve_overload'
  3950:   syms (rs:recstop)
  3951:   sr
  3952:   (fs : entry_kind_t list)
  3953:   (name: string)
  3954:   (sufs : btypecode_t list)
  3955:   (ts:btypecode_t list)
  3956: : (entry_kind_t * btypecode_t * (int * btypecode_t) list * btypecode_t list) option =
  3957: 
  3958:   if length fs = 0 then None else
  3959:   let bt sr i t =
  3960:     let env = inner_build_env syms rs (Some i) in
  3961:     bind_type syms env sr t
  3962:   in
  3963:     let fs = trclose syms rs sr fs in
  3964:     overload syms bt sr fs name sufs ts
  3965: 
  3966: (* an environment is a list of hastables, mapping
  3967:    names to definition indicies. Each entity defining
  3968:    a scope contains one hashtable, and a pointer to
  3969:    its parent, if any. The name 'root' is special,
  3970:    it is the name of the single top level module
  3971:    created by the desugaring phase. We have to be
  3972:    able to find this name, so if when we run out
  3973:    of parents, which is when we hit the top module,
  3974:    we create a parent name map with a single entry
  3975:    'top'->NonFunctionEntry 0.
  3976: *)
  3977: 
  3978: and split_dirs open_excludes dirs :
  3979:     qualified_name_t list *
  3980:     qualified_name_t list *
  3981:     (string * qualified_name_t) list
  3982: =
  3983:   let opens =
  3984:      concat
  3985:      (
  3986:        map
  3987:        (fun x -> match x with
  3988:          | DIR_open qn -> if mem qn open_excludes then [] else [qn]
  3989:          | DIR_inject_module qn -> []
  3990:          | DIR_use (n,qn) -> []
  3991:        )
  3992:        dirs
  3993:      )
  3994:   and includes =
  3995:      concat
  3996:      (
  3997:        map
  3998:        (fun x -> match x with
  3999:          | DIR_open qn -> []
  4000:          | DIR_inject_module qn -> [qn]
  4001:          | DIR_use (n,qn) -> []
  4002:        )
  4003:        dirs
  4004:      )
  4005:   and uses =
  4006:      concat
  4007:      (
  4008:        map
  4009:        (fun x -> match x with
  4010:          | DIR_open qn -> []
  4011:          | DIR_inject_module qn -> []
  4012:          | DIR_use (n,qn) -> [n,qn]
  4013:        )
  4014:        dirs
  4015:      )
  4016:   in opens, includes, uses
  4017: 
  4018: and get_includes' syms includes index =
  4019:   if not (mem index !includes) then
  4020:   begin
  4021:     includes := index :: !includes;
  4022:     let env = mk_bare_env syms index in
  4023:     match Hashtbl.find syms.dfns index with
  4024:     {id=id;sr=sr;parent=parent;vs=vs;pubmap=table;dirs=dirs} ->
  4025:     iter
  4026:     (fun x -> match x with
  4027:       | DIR_open _
  4028:       | DIR_use _ -> ()
  4029:       | DIR_inject_module qn ->
  4030:         let i,ts =
  4031:           try lookup_qn_in_env syms env qn
  4032:           with Not_found -> failwith "QN NOT FOUND"
  4033:         in
  4034:           get_includes' syms includes i
  4035:     )
  4036:     dirs
  4037:   end
  4038: 
  4039: and bind_dir
  4040:   syms
  4041:   (env:env_t) rs
  4042:   qn
  4043: : int =
  4044:   let sr = ("dummy",0,0,0,0) in
  4045:   (*
  4046:   print_endline ("Try to bind dir " ^ string_of_qualified_name qn);
  4047:   *)
  4048:   let result =
  4049:     try
  4050:       lookup_qn_in_env' syms env
  4051:       {rs with open_excludes = qn::rs.open_excludes }
  4052:       qn
  4053:     with Not_found -> failwith "QN NOT FOUND"
  4054:   in
  4055:   match result with
  4056:   | i,ts -> i
  4057: 
  4058: and pub_table_dir
  4059:   syms
  4060:   i
  4061: : name_map_t =
  4062:   match get_data syms.dfns i with
  4063:   | {sr=sr; pubmap=table;symdef=`SYMDEF_module} -> table
  4064:   | {sr=sr} -> clierr sr "[map_dir] Expected module"
  4065: 
  4066: 
  4067: and get_pub_tables syms env rs dirs =
  4068:   let _,includes,_ = split_dirs rs.open_excludes dirs in
  4069:   let opens = uniq_list (map (bind_dir syms env rs) includes) in
  4070:   let includes = ref [] in
  4071:   iter (get_includes' syms includes) opens;
  4072:   let includes = uniq_list !includes in
  4073:   let tables = map (pub_table_dir syms) includes in
  4074:   tables
  4075: 
  4076: and mk_bare_env syms index =
  4077:   match Hashtbl.find syms.dfns index with
  4078:   {id=id;parent=parent;privmap=table} -> (index,id,table,[]) ::
  4079:   match parent with
  4080:   | None -> []
  4081:   | Some index -> mk_bare_env syms index
  4082: 
  4083: and merge_opens syms env rs (opens,includes,uses) =
  4084:   (*
  4085:   print_endline ("MERGE OPENS ");
  4086:   *)
  4087:   let use_map = Hashtbl.create 97 in
  4088:   iter
  4089:   (fun (n,qn) ->
  4090:     let entry,_ = lookup_qn_in_env2' syms env rs qn in
  4091:     match entry with
  4092: 
  4093:     | NonFunctionEntry _ ->
  4094:       if Hashtbl.mem use_map n
  4095:       then failwith "Duplicate non function used"
  4096:       else Hashtbl.add use_map n entry
  4097: 
  4098:     | FunctionEntry ls ->
  4099:       let entry2 =
  4100:         try Hashtbl.find use_map  n
  4101:         with Not_found -> FunctionEntry []
  4102:       in
  4103:       match entry2 with
  4104:       | NonFunctionEntry _ ->
  4105:         failwith "Use function and non-function kinds"
  4106:       | FunctionEntry ls2 ->
  4107:         Hashtbl.replace use_map n (FunctionEntry (ls @ ls2))
  4108:   )
  4109:   uses
  4110:   ;
  4111:   (*
  4112:   print_endline "Binding opens ..";
  4113:   *)
  4114:   let opens = uniq_list (map (bind_dir syms env rs) opens) in
  4115:   (*
  4116:   print_endline "Binding complete";
  4117:   *)
  4118:   let opens = uniq_cat opens (map (bind_dir syms env rs) includes) in
  4119: 
  4120:   let includes = ref [] in
  4121:   iter (get_includes' syms includes) opens;
  4122:   let includes = uniq_list !includes in
  4123:   let tables = map (pub_table_dir syms) includes in
  4124:   use_map::tables
  4125: 
  4126: and build_env'' syms rs index : env_t =
  4127:   match Hashtbl.find syms.dfns index with
  4128:   {id=id; parent=parent;privmap=table;dirs=dirs} ->
  4129:   let opens,includes,uses = split_dirs rs.open_excludes dirs in
  4130:   let env = inner_build_env syms rs parent in
  4131:   let env' = (index,id,table,[])::env in
  4132:   let second = merge_opens syms env' rs (opens,includes,uses) in
  4133:   (index,id,table,second)::env
  4134: 
  4135: and inner_build_env syms rs parent : env_t =
  4136:   match parent with
  4137:   | None -> []
  4138:   | Some i ->
  4139:     try
  4140:       Hashtbl.find syms.env_cache i
  4141:     with
  4142:       Not_found ->
  4143:        let env = build_env'' syms rs i in
  4144:        Hashtbl.add syms.env_cache i env;
  4145:        env
  4146: 
  4147: and build_env syms parent : env_t =
  4148:   inner_build_env syms rsground parent
  4149: 
  4150: 
  4151: (*===========================================================*)
  4152: (* MODULE STUFF *)
  4153: (*===========================================================*)
  4154: 
  4155: (* This routine takes a bound type, and produces a unique form
  4156:    of the bound type, by again factoring out type aliases.
  4157:    The type aliases can get reintroduced by map_type,
  4158:    if an abstract type is mapped to a typedef, so we have
  4159:    to factor them out again .. YUK!!
  4160: *)
  4161: 
  4162: and rebind_btype syms env sr ts t: btypecode_t =
  4163:   let rbt t = rebind_btype syms env sr ts t in
  4164:   match t with
  4165:   | `BTYP_inst (i,_) ->
  4166:     begin match get_data syms.dfns i with
  4167:     | {symdef=`SYMDEF_type_alias t'} ->
  4168:       bind_type syms env sr t'
  4169:     | _ -> t
  4170:     end
  4171: 
  4172:   | `BTYP_typesetunion ts -> `BTYP_typesetunion (map rbt ts)
  4173:   | `BTYP_typesetintersection ts -> `BTYP_typesetintersection (map rbt ts)
  4174: 
  4175:   | `BTYP_tuple ts -> `BTYP_tuple (map rbt ts)
  4176:   | `BTYP_record ts ->
  4177:       let ss,ts = split ts in
  4178:       `BTYP_record (combine ss (map rbt ts))
  4179: 
  4180:   | `BTYP_variant ts ->
  4181:       let ss,ts = split ts in
  4182:       `BTYP_variant (combine ss (map rbt ts))
  4183: 
  4184:   | `BTYP_typeset ts ->  `BTYP_typeset (map rbt ts)
  4185:   | `BTYP_intersect ts ->  `BTYP_intersect (map rbt ts)
  4186: 
  4187:   | `BTYP_sum ts ->
  4188:     let ts = map rbt ts in
  4189:     if all_units ts then
  4190:       `BTYP_unitsum (length ts)
  4191:     else
  4192:       `BTYP_sum ts
  4193: 
  4194:   | `BTYP_function (a,r) -> `BTYP_function (rbt a, rbt r)
  4195:   | `BTYP_cfunction (a,r) -> `BTYP_cfunction (rbt a, rbt r)
  4196:   | `BTYP_pointer t -> `BTYP_pointer (rbt t)
  4197:   | `BTYP_lvalue t -> lvalify (rbt t)
  4198:   | `BTYP_array (t1,t2) -> `BTYP_array (rbt t1, rbt t2)
  4199: 
  4200:   | `BTYP_unitsum _
  4201:   | `BTYP_void
  4202:   | `BTYP_fix _ -> t
  4203: 
  4204:   | `BTYP_var (i,mt) -> clierr sr ("[rebind_type] Unexpected type variable " ^ sbt syms.dfns t)
  4205:   | `BTYP_apply _
  4206:   | `BTYP_typefun _
  4207:   | `BTYP_type
  4208:   | `BTYP_type_tuple _
  4209:   | `BTYP_type_match _
  4210:     -> clierr sr ("[rebind_type] Unexpected metatype " ^ sbt syms.dfns t)
  4211: 
  4212: 
  4213: and check_module syms name sr entries ts =
  4214:     begin match entries with
  4215:     | NonFunctionEntry (index) ->
  4216:       begin match get_data syms.dfns index with
  4217:       | {dirs=dirs;pubmap=table;symdef=`SYMDEF_module} ->
  4218:         Simple_module (index,ts,table,dirs)
  4219:       | {id=id;sr=sr'} ->
  4220:         clierr sr
  4221:         (
  4222:           "Expected '" ^ id ^ "' to be module in: " ^
  4223:           short_string_of_src sr ^ ", found: " ^
  4224:           short_string_of_src sr'
  4225:         )
  4226:       end
  4227:     | _ ->
  4228:       failwith
  4229:       (
  4230:         "Expected non function entry for " ^ name
  4231:       )
  4232:     end
  4233: 
  4234: (* the top level table only has a single entry,
  4235:   the root module, which is the whole file
  4236: 
  4237:   returns the root name, table index, and environment
  4238: *)
  4239: 
  4240: and eval_module_expr syms env e : module_rep_t =
  4241:   (*
  4242:   print_endline ("Eval module expr " ^ string_of_expr e);
  4243:   *)
  4244:   match e with
  4245:   | `AST_name (sr,name,ts) ->
  4246:     let entries = inner_lookup_name_in_env syms env rsground sr name in
  4247:     check_module syms name sr entries ts
  4248: 
  4249:   | `AST_lookup (sr,(e,name,ts)) ->
  4250:     let result = eval_module_expr syms env e in
  4251:     begin match result with
  4252:       | Simple_module (index,ts',htab,dirs) ->
  4253:       let env' = mk_bare_env syms index in
  4254:       let tables = get_pub_tables syms env' rsground dirs in
  4255:       let result = lookup_name_in_table_dirs htab tables sr name in
  4256:         begin match result with
  4257:         | Some x ->
  4258:           check_module syms name sr x (ts' @ ts)
  4259: 
  4260:         | None -> clierr sr
  4261:           (
  4262:             "Can't find " ^ name ^ " in module"
  4263:           )
  4264:         end
  4265: 
  4266:     end
  4267: 
  4268:   | _ ->
  4269:     let sr = src_of_expr e in
  4270:     clierr sr
  4271:     (
  4272:       "Invalid module expression " ^
  4273:       string_of_expr e
  4274:     )
  4275: 
  4276: 
End ocaml section to src/flx_lookup.ml[1]