5.38. 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: open Flx_overload
     6: 
     7: val lookup_name_in_htab:
     8:   name_map_t ->
     9:   string ->
    10:   entry_set_t option
    11: 
    12: val build_env:
    13:   sym_state_t ->
    14:   int option -> (* parent *)
    15:   env_t
    16: 
    17: val lookup_name_in_env :
    18:   sym_state_t ->
    19:   env_t ->
    20:   range_srcref ->
    21:   id_t ->
    22:   entry_set_t
    23: 
    24: val lookup_qn_in_env :
    25:   sym_state_t ->
    26:   env_t ->
    27:   qualified_name_t ->
    28:   entry_kind_t * typecode_t list
    29: 
    30: val lookup_qn_in_env2:
    31:   sym_state_t ->
    32:   env_t ->
    33:   qualified_name_t ->
    34:   entry_set_t * typecode_t list
    35: 
    36: val lookup_sn_in_env :
    37:   sym_state_t ->
    38:   env_t ->
    39:   suffixed_name_t ->
    40:   int * btypecode_t list
    41: 
    42: val lookup_code_in_env:
    43:   sym_state_t ->
    44:   env_t ->
    45:   range_srcref ->
    46:   qualified_name_t ->
    47:   entry_kind_t list * typecode_t list
    48: 
    49: (** This routine takes an unbound type term
    50: and binds it. The term may contain explicit
    51: type variables. If the term denotes a generative
    52: type (abstract, union, or struct) then an instance
    53: is made with type variables for the indices.
    54: 
    55: Note that the result of binding a term with type
    56: variables is not a type function.
    57: *)
    58: 
    59: val bind_type:
    60:   sym_state_t ->
    61:   env_t ->
    62:   range_srcref ->
    63:   typecode_t ->
    64:   btypecode_t
    65: 
    66: val eval_module_expr:
    67:   sym_state_t ->
    68:   env_t ->
    69:   expr_t ->
    70:   module_rep_t
    71: 
    72: val resolve_overload:
    73:   sym_state_t ->
    74:   env_t ->
    75:   range_srcref ->
    76:   entry_kind_t list ->
    77:   id_t ->
    78:   btypecode_t list ->
    79:   btypecode_t list ->      (* explicit param/arg bindings *)
    80:   overload_result option
    81: 
    82: val bind_expression :
    83:   sym_state_t ->
    84:   env_t ->
    85:   expr_t ->
    86:   tbexpr_t
    87: 
    88: val bind_expression_with_args :
    89:   sym_state_t ->
    90:   env_t ->
    91:   expr_t ->
    92:   tbexpr_t list ->
    93:   tbexpr_t
    94: 
    95: val typeofindex :
    96:   sym_state_t ->
    97:   int ->
    98:   btypecode_t
    99: 
   100: val typeofindex_with_ts:
   101:   sym_state_t ->
   102:   range_srcref ->
   103:   int ->
   104:   btypecode_t list ->
   105:   btypecode_t
   106: 
   107: val typeof_literal:
   108:   sym_state_t ->
   109:   env_t ->
   110:   range_srcref ->
   111:   literal_t ->
   112:   btypecode_t
   113: 
   114: val lookup_qn_with_sig:
   115:   sym_state_t ->
   116:   range_srcref ->
   117:   range_srcref ->
   118:   env_t ->
   119:   qualified_name_t ->
   120:   btypecode_t list ->
   121:   tbexpr_t
   122: 
   123: val bind_regdef:
   124:   sym_state_t ->
   125:   env_t ->
   126:   int list -> (* regexp exclusion list *)
   127:   regexp_t ->
   128:   regexp_t
   129: 
End ocaml section to src/flx_lookup.mli[1]
Start ocaml section to src/flx_lookup.ml[1 /1 ]
     1: # 226 "./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 dummy_sr = "[flx_lookup] generated", 0,0,0,0
    21: 
    22: let unit_t = `BTYP_tuple []
    23: let dfltvs_aux = { raw_type_constraint=`TYP_tuple []; raw_typeclass_reqs=[]}
    24: let dfltvs = [],dfltvs_aux
    25: 
    26: (* use fresh variables, but preserve names *)
    27: let mkentry syms (vs:ivs_list_t) i =
    28:   let n = length (fst vs) in
    29:   let base = !(syms.counter) in syms.counter := !(syms.counter) + n;
    30:   let ts = map (fun i ->
    31:     (*
    32:     print_endline ("[mkentry] Fudging type variable type " ^ si i);
    33:     *)
    34:     `BTYP_var (i+base,`BTYP_type 0)) (nlist n)
    35:   in
    36:   let vs = map2 (fun i (n,_,_) -> n,i+base) (nlist n) (fst vs) in
    37:   {base_sym=i; spec_vs=vs; sub_ts=ts}
    38: 
    39: 
    40: let lvalify t = match t with
    41:   | `BTYP_lvalue _ -> t
    42:   | t -> `BTYP_lvalue t
    43: 
    44: exception Found of int
    45: exception Tfound of btypecode_t
    46: 
    47: type kind_t = Parameter | Other
    48: 
    49: let get_data table index : symbol_data_t =
    50:   try Hashtbl.find table index
    51:   with Not_found ->
    52:     failwith ("[Flx_lookup.get_data] No definition of <" ^ string_of_int index ^ ">")
    53: 
    54: let lookup_name_in_htab htab name : entry_set_t option =
    55:   (* print_endline ("Lookup name in htab: " ^ name); *)
    56:   try Some (Hashtbl.find htab name)
    57:   with Not_found -> None
    58: 
    59: let merge_functions
    60:   (opens:entry_set_t list)
    61:   name
    62: : entry_kind_t list =
    63:   fold_left
    64:     (fun init x -> match x with
    65:     | `FunctionEntry ls ->
    66:       fold_left
    67:       (fun init x ->
    68:         if mem x init then init else x :: init
    69:       )
    70:       init ls
    71:     | `NonFunctionEntry x ->
    72:       failwith
    73:       ("[merge_functions] Expected " ^
    74:         name ^ " to be function overload set in all open modules, got non-function:\n" ^
    75:         string_of_entry_kind x
    76:       )
    77:     )
    78:   []
    79:   opens
    80: 
    81: let lookup_name_in_table_dirs table dirs sr name : entry_set_t option =
    82:   (*
    83:   print_endline ("Lookup name " ^ name ^ " in table dirs");
    84:   flush stdout;
    85:   *)
    86:   match lookup_name_in_htab table name with
    87:   | Some x as y ->
    88:     (*
    89:     print_endline ("Lookup_name_in_htab found " ^ name);
    90:     *)
    91:     y
    92:   | None ->
    93:   let opens =
    94:     concat
    95:     (
    96:       map
    97:       (fun table ->
    98:         match lookup_name_in_htab table name with
    99:         | Some x -> [x]
   100:         | None -> []
   101:       )
   102:       dirs
   103:     )
   104:   in
   105:   match opens with
   106:   | [x] -> Some x
   107:   | `FunctionEntry ls :: rest ->
   108:     (*
   109:     print_endline "HERE 3";
   110:     *)
   111:     Some (`FunctionEntry (merge_functions opens name))
   112: 
   113:   | (`NonFunctionEntry (i)) as some ::_ ->
   114:     if
   115:       fold_left
   116:         (function t -> function
   117:           | `NonFunctionEntry (j) when i = j -> t
   118:           | _ -> false
   119:         )
   120:         true
   121:         opens
   122:     then
   123:       Some some
   124:     else begin
   125:       iter
   126:       (fun es ->  print_endline ("Symbol " ^(string_of_entry_set es)))
   127:       opens
   128:       ;
   129:       clierr sr ("[lookup_name_in_table_dirs] Conflicting nonfunction definitions for "^
   130:         name ^" found in open modules"
   131:       )
   132:     end
   133:   | [] -> None
   134: 
   135: 
   136: type recstop = {
   137:   idx_fixlist: int list;
   138:   type_alias_fixlist: (int * int) list;
   139:   as_fixlist: (string * int) list;
   140:   expr_fixlist: (expr_t * int) list;
   141:   depth:int;
   142:   open_excludes : (ivs_list_t * qualified_name_t) list
   143: }
   144: 
   145: let rsground= {
   146:   idx_fixlist = [];
   147:   type_alias_fixlist = [];
   148:   as_fixlist = [];
   149:   expr_fixlist = [];
   150:   depth = 0;
   151:   open_excludes = []
   152: }
   153: 
   154: (* this ugly thing merges a list of function entries
   155: some of which might be inherits, into a list of
   156: actual functions
   157: *)
   158: 
   159: module EntrySet = Set.Make(
   160:   struct
   161:     type t = entry_kind_t
   162:     let compare = compare
   163:   end
   164: )
   165: 
   166: let rec trclose syms rs sr fs =
   167:   let inset = ref EntrySet.empty in
   168:   let outset = ref EntrySet.empty in
   169:   let exclude = ref EntrySet.empty in
   170:   let append fs = iter (fun i -> inset := EntrySet.add i !inset) fs in
   171: 
   172:   let rec trclosem () =
   173:     if EntrySet.is_empty !inset then ()
   174:     else
   175:       (* grab an element *)
   176:       let x = EntrySet.choose !inset in
   177:       inset := EntrySet.remove x !inset;
   178: 
   179:       (* loop if already handled *)
   180:       if EntrySet.mem x !exclude then trclosem ()
   181:       else begin
   182:         (* say we're handling this one *)
   183:         exclude := EntrySet.add x !exclude;
   184: 
   185:         match Hashtbl.find syms.dfns (sye x) with
   186:         | {parent=parent; sr=sr2; symdef=`SYMDEF_inherit_fun qn} ->
   187:           let env = build_env syms parent in
   188:           begin match fst (lookup_qn_in_env2' syms env rs qn) with
   189:           | `NonFunctionEntry _ -> clierr2 sr sr2 "Inherit fun doesn't denote function set"
   190:           | `FunctionEntry fs' -> append fs'; trclosem ()
   191:           end
   192: 
   193:         | _ -> outset := EntrySet.add x !outset; trclosem ()
   194:       end
   195:   in
   196:   append fs;
   197:   trclosem ();
   198:   let output = ref [] in
   199:   EntrySet.iter (fun i -> output := i :: !output) !outset;
   200:   !output
   201: 
   202: and resolve_inherits syms rs sr x =
   203:   match x with
   204:   | `NonFunctionEntry z ->
   205:     begin match Hashtbl.find syms.dfns (sye z) with
   206:     | {parent=parent; symdef=`SYMDEF_inherit qn} ->
   207:       (*
   208:       print_endline ("Found an inherit symbol qn=" ^ string_of_qualified_name qn);
   209:       *)
   210:       let env = inner_build_env syms rs parent in
   211:       (*
   212:       print_endline "Environment built for lookup ..";
   213:       *)
   214:       fst (lookup_qn_in_env2' syms env rs qn)
   215:     | {sr=sr2; symdef=`SYMDEF_inherit_fun qn} ->
   216:       clierr2 sr sr2
   217:       "NonFunction inherit denotes function"
   218:     | _ -> x
   219:     end
   220:   | `FunctionEntry fs -> `FunctionEntry (trclose syms rs sr fs)
   221: 
   222: and lookup_name_in_env syms (env:env_t) sr name : entry_set_t =
   223:  inner_lookup_name_in_env syms (env:env_t) rsground sr name
   224: 
   225: and inner_lookup_name_in_env syms (env:env_t) rs sr name : entry_set_t =
   226:   (*
   227:   print_endline ("[lookup_name_in_env] " ^ name);
   228:   *)
   229:   let rec aux env =
   230:     match env with
   231:     | [] -> None
   232:     | (_,_,table,dirs) :: tail ->
   233:       match lookup_name_in_table_dirs table dirs sr name with
   234:       | Some x as y -> y
   235:       | None -> aux tail
   236:   in
   237:     match aux env with
   238:     | Some x ->
   239:       (*
   240:       print_endline "[lookup_name_in_env] Got result, resolve inherits";
   241:       *)
   242:       resolve_inherits syms rs sr x
   243:     | None ->
   244:       clierr sr
   245:       (
   246:         "[lookup_name_in_env]: Name '" ^
   247:         name ^
   248:         "' not found in environment (depth "^
   249:         string_of_int (length env)^ ")"
   250:       )
   251: 
   252: (* This routine looks up a qualified name in the
   253:    environment and returns an entry_set_t:
   254:    can be either non-function or function set
   255: *)
   256: and lookup_qn_in_env2'
   257:   syms
   258:   (env:env_t)
   259:   (rs:recstop)
   260:   (qn: qualified_name_t)
   261:   : entry_set_t * typecode_t list
   262: =
   263:   (*
   264:   print_endline ("[lookup_qn_in_env2] qn=" ^ string_of_qualified_name qn);
   265:   *)
   266:   match qn with
   267:   | `AST_callback (sr,qn) -> clierr sr "[lookup_qn_in_env2] qualified name is callback [not implemented yet]"
   268:   | `AST_void sr -> clierr sr "[lookup_qn_in_env2] qualified name is void"
   269:   | `AST_case_tag (sr,_) -> clierr sr "[lookup_qn_in_env2] Can't lookup a case tag"
   270:   | `AST_typed_case (sr,_,_) -> clierr sr "[lookup_qn_in_env2] Can't lookup a typed case tag"
   271:   | `AST_index (sr,name,_) ->
   272:     print_endline ("[lookup_qn_in_env2] synthetic name " ^ name);
   273:     clierr sr "[lookup_qn_in_env2] Can't lookup a synthetic name"
   274: 
   275:   | `AST_name (sr,name,ts) ->
   276:     (*
   277:     print_endline ("Found simple name " ^ name);
   278:     *)
   279:     inner_lookup_name_in_env syms env rs sr name, ts
   280: 
   281:   | `AST_the (sr,qn) ->
   282:     print_endline ("[lookup_qn_in_env2'] AST_the " ^ string_of_qualified_name qn);
   283:     let es,ts = lookup_qn_in_env2' syms env rs qn in
   284:     begin match es with
   285:     | `NonFunctionEntry  _
   286:     | `FunctionEntry [_] -> es,ts
   287:     | _ -> clierr sr
   288:       "'the' expression denotes non-singleton function set"
   289:     end
   290: 
   291:   | `AST_lookup (sr,(me,name,ts)) ->
   292:     (*
   293:     print_endline ("Searching for name " ^ name);
   294:     *)
   295:     match eval_module_expr syms env me with
   296:     | Simple_module (impl,ts', htab,dirs) ->
   297:       let env' = mk_bare_env syms impl in
   298:       let tables = get_pub_tables syms env' rs dirs in
   299:       let result = lookup_name_in_table_dirs htab tables sr name in
   300:       match result with
   301:       | Some entry ->
   302:         resolve_inherits syms rs sr entry,
   303:         ts' @ ts
   304:       | None ->
   305:         clierr sr
   306:         (
   307:           "[lookup_qn_in_env2] Can't find " ^ name
   308:         )
   309: 
   310:       (*
   311:       begin
   312:       try
   313:         let entry = Hashtbl.find htab name in
   314:         resolve_inherits syms rs sr entry,
   315:         ts' @ ts
   316:       with Not_found ->
   317:         clierr sr
   318:         (
   319:           "[lookup_qn_in_env2] Can't find " ^ name
   320:         )
   321:       end
   322:       *)
   323: 
   324: and lookup_qn_in_env2
   325:   syms
   326:   (env:env_t)
   327:   (qn: qualified_name_t)
   328:   : entry_set_t * typecode_t list
   329: =
   330:   lookup_qn_in_env2' syms env rsground qn
   331: 
   332: 
   333: (* this one isn't recursive i hope .. *)
   334: and lookup_code_in_env syms env sr qn =
   335:   let result =
   336:     try Some (lookup_qn_in_env2' syms env rsground qn)
   337:     with _ -> None
   338:   in match result with
   339:   | Some (`NonFunctionEntry x,ts) ->
   340:     clierr sr
   341:     (
   342:       "[lookup_qn_in_env] Not expecting " ^
   343:       string_of_qualified_name qn ^
   344:       " to be non-function (code insertions use function entries) "
   345:     )
   346: 
   347:   | Some (`FunctionEntry x,ts) ->
   348:     iter
   349:     (fun i ->
   350:       match Hashtbl.find syms.dfns (sye i) with
   351:       | {symdef=`SYMDEF_insert _} -> ()
   352:       | {id=id; vs=vs; symdef=y} -> clierr sr
   353:         (
   354:           "Expected requirement '"^
   355:           string_of_qualified_name qn ^
   356:           "' to bind to a header or body insertion, instead got:\n" ^
   357:           string_of_symdef y id vs
   358:         )
   359:     )
   360:     x
   361:     ;
   362:     x,ts
   363: 
   364:   | None -> [mkentry syms dfltvs 0],[]
   365: 
   366: and lookup_qn_in_env
   367:   syms
   368:   (env:env_t)
   369:   (qn: qualified_name_t)
   370:   : entry_kind_t  * typecode_t list
   371: =
   372:   lookup_qn_in_env' syms env rsground qn
   373: 
   374: and lookup_qn_in_env'
   375:   syms
   376:   (env:env_t) rs
   377:   (qn: qualified_name_t)
   378:   : entry_kind_t  * typecode_t list
   379: =
   380:   match lookup_qn_in_env2' syms env rs qn with
   381:     | `NonFunctionEntry x,ts -> x,ts
   382:     | `FunctionEntry _,_ ->
   383:       let sr = src_of_expr (qn:>expr_t) in
   384:       clierr sr
   385:       (
   386:         "[lookup_qn_in_env'] Not expecting " ^
   387:         string_of_qualified_name qn ^
   388:         " to be function set"
   389:       )
   390: 
   391: and lookup_uniq_in_env
   392:   syms
   393:   (env:env_t)
   394:   (qn: qualified_name_t)
   395:   : entry_kind_t  * typecode_t list
   396: =
   397:   match lookup_qn_in_env2' syms env rsground qn with
   398:     | `NonFunctionEntry x,ts -> x,ts
   399:     | `FunctionEntry [x],ts -> x,ts
   400:     | _ ->
   401:       let sr = src_of_expr (qn:>expr_t) in
   402:       clierr sr
   403:       (
   404:         "[lookup_uniq_in_env] Not expecting " ^
   405:         string_of_qualified_name qn ^
   406:         " to be non-singleton function set"
   407:       )
   408: 
   409: and lookup_function_in_env
   410:   syms
   411:   (env:env_t)
   412:   (qn: qualified_name_t)
   413:   : entry_kind_t  * typecode_t list
   414: =
   415:   match lookup_qn_in_env2' syms env rsground qn with
   416:     | `FunctionEntry [x],ts -> x,ts
   417:     | _ ->
   418:       let sr = src_of_expr (qn:>expr_t) in
   419:       clierr sr
   420:       (
   421:         "[lookup_qn_in_env] Not expecting " ^
   422:         string_of_qualified_name qn ^
   423:         " to be non-function or non-singleton function set"
   424:       )
   425: 
   426: and lookup_sn_in_env
   427:   syms
   428:   (env:env_t)
   429:   (sn: suffixed_name_t)
   430:   : int * btypecode_t list
   431: =
   432:   let sr = src_of_expr (sn:>expr_t) in
   433:   let bt t = bind_type syms env sr t in
   434:   match sn with
   435:   | #qualified_name_t as x ->
   436:     begin match
   437:       lookup_qn_in_env syms env x
   438:     with
   439:     | index,ts -> (sye index),map bt ts
   440:     end
   441: 
   442:   | `AST_suffix (sr,(qn,suf)) ->
   443:     let bsuf = bind_type syms env sr suf in
   444:     (* OUCH HACKERY *)
   445:     let ((be,t) : tbexpr_t) =
   446:       lookup_qn_with_sig'
   447:       syms
   448:       sr sr
   449:       env rsground
   450:       qn [bsuf]
   451:     in match be with
   452:     | `BEXPR_name (index,ts) ->
   453:       index,ts
   454:     | `BEXPR_closure (index,ts) -> index,ts
   455: 
   456:     | _ -> failwith "Expected expression to be index"
   457: 
   458: (* This routine binds a type expression to a bound type expression.
   459:    Note in particular that a type alias is replaced by what
   460:    it as an alias for, recursively so that the result
   461:    globally unique
   462: 
   463:    if params is present it is a list mapping strings to types
   464:    possibly bound type variable
   465: 
   466:    THIS IS WEIRD .. expr_fixlist is propagated, but 'depth'
   467:    isn't. But the depth is essential to insert the correct
   468:    fixpoint term .. ????
   469: 
   470:    i think this arises from:
   471: 
   472:    val x = e1 + y;
   473:    val y = e2 + x;
   474: 
   475:    here, the implied typeof() operator is used
   476:    twice: the first bind expression invoking a second
   477:    bind expression which would invoke the first again ..
   478:    here we have to propagate the bind_expression
   479:    back to the original call on the first term,
   480:    but we don't want to accumulate depths? Hmmm...
   481:    I should test that ..
   482: 
   483: *)
   484: and bind_type syms env sr t : btypecode_t =
   485:   (*
   486:   print_endline ("[bind_type] " ^ string_of_typecode t);
   487:   *)
   488:   let mkenv i = build_env syms (Some i) in
   489:   let bt:btypecode_t =
   490:     try
   491:       bind_type' syms env rsground sr t [] mkenv
   492: 
   493:     with
   494:       | Free_fixpoint b ->
   495:         clierr sr
   496:         ("Unresolvable recursive type " ^ sbt syms.dfns b)
   497:   in
   498:   (*
   499:   print_endline ("Bound type= " ^ sbt syms.dfns bt);
   500:   *)
   501:   let bt = beta_reduce syms sr bt
   502:   in
   503:     (*
   504:     print_endline ("Beta reduced type= " ^ sbt syms.dfns bt);
   505:     *)
   506:     bt
   507: 
   508: and bind_expression syms env e  =
   509:   let sr = src_of_expr e in
   510:   let e',t' =
   511:     try
   512:      let x = bind_expression' syms env rsground e [] in
   513:      (*
   514:      print_endline ("Bound expression " ^
   515:        string_of_bound_expression_with_type syms.dfns x
   516:      );
   517:      *)
   518:      x
   519:     with
   520:      | Free_fixpoint b ->
   521:        clierr sr
   522:        ("Circular dependency typing expression " ^ string_of_expr e)
   523:      | SystemError (sr,msg) as x ->
   524:        print_endline ("System Error binding expression " ^ string_of_expr e);
   525:        raise x
   526: 
   527:      | ClientError (sr,msg) as x ->
   528:        print_endline ("Client Error binding expression " ^ string_of_expr e);
   529:        raise x
   530: 
   531:      | Failure msg as x ->
   532:        print_endline ("Failure binding expression " ^ string_of_expr e);
   533:        raise x
   534: 
   535:   in
   536:     let t' = beta_reduce syms sr t' in
   537:     e',t'
   538: 
   539: and expand_typeset t =
   540:   match t with
   541:   | `BTYP_type_tuple ls
   542:   | `BTYP_typeset ls
   543:   | `BTYP_typesetunion ls -> fold_left (fun ls t -> expand_typeset t @ ls) [] ls
   544:   | x -> [x]
   545: 
   546: and handle_typeset syms sr elt tset =
   547:   let ls = expand_typeset tset in
   548:   (* x isin { a,b,c } is the same as
   549:     typematch x with
   550:     | a => 1
   551:     | b => 1
   552:     | c => 1
   553:     | _ => 0
   554:     endmatch
   555: 
   556:     ** THIS CODE ONLY WORKS FOR BASIC TYPES **
   557: 
   558:     This is because we don't know what to do with any
   559:     type variables in the terms of the set. The problem
   560:     is that 'bind type' just replaces them with bound
   561:     variables. We have to assume they're not pattern
   562:     variables at the moment, therefore they're variables
   563:     from the environment.
   564: 
   565:     We should really allow for patterns, however bound
   566:     patterns aren't just types, but types with binders
   567:     indicating 'as' assignments and pattern variables.
   568: 
   569:     Crudely -- typesets are a hack that we should get
   570:     rid of in the future, since a typematch is just
   571:     more general .. however we have no way to generalise
   572:     type match cases so they can be named at the moment.
   573: 
   574:     This is why we have typesets.. so I need to fix them,
   575:     so the list of things in a typeset is actually
   576:     a sequence of type patterns, not types.
   577: 
   578:   *)
   579:   let e = IntSet.empty in
   580:   let un = `BTYP_tuple [] in
   581:   let lss = rev_map (fun t -> {pattern=t; pattern_vars=e; assignments=[]},un) ls in
   582:   let fresh = !(syms.counter) in incr (syms.counter);
   583:   let dflt =
   584:     {
   585:       pattern=`BTYP_var (fresh,`BTYP_type 0);
   586:       pattern_vars = IntSet.singleton fresh;
   587:       assignments=[]
   588:     },
   589:     `BTYP_void
   590:   in
   591:   let lss = rev (dflt :: lss) in
   592:   `BTYP_type_match (elt, lss)
   593: 
   594: 
   595: 
   596: 
   597: (* =========================================== *)
   598: (* INTERNAL BINDING ROUTINES *)
   599: (* =========================================== *)
   600: 
   601: (* RECURSION DETECTORS
   602: 
   603: There are FOUR type recursion detectors:
   604: 
   605: idx_fixlist is a list of indexes, used by
   606: bind_index to detect a recursion determining
   607: the type of a function or variable:
   608: the depth is calculated from the list length:
   609: this arises from bind_expression, which uses
   610: bind type : bind_expression is called to deduce
   611: a function return type from returned expressions
   612: 
   613: TEST CASE:
   614:   val x = (x,x) // type is ('a * 'a) as 'a
   615: 
   616: RECURSION CYCLE:
   617:   typeofindex' -> bind_type'
   618: 
   619: type_alias_fixlist is a list of indexes, used by
   620: bind_type_index to detect a recursive type alias,
   621: [list contains depth]
   622: 
   623: TEST CASE:
   624:   typedef a = a * a // type is ('a * 'a) as 'a
   625: 
   626: 
   627: RECURSION CYCLE:
   628:   bind_type' -> type_of_type_index
   629: 
   630: as_fixlist is a list of (name,depth) pairs, used by
   631: bind_type' to detect explicit fixpoint variables
   632: from the TYP_as terms (x as fv)
   633: [list contains depth]
   634: 
   635: TEST CASE:
   636:   typedef a = b * b as b // type is ('a * 'a) as 'a
   637: 
   638: RECURSION CYCLE:
   639:   typeofindex' -> bind_type'
   640: 
   641: expr_fixlist is a list of (expression,depth)
   642: used by bind_type' to detect recursion from
   643: typeof(e) type terms
   644: [list contains depth]
   645: 
   646: TEST CASE:
   647:   val x: typeof(x) = (x,x) // type is ('a * 'a) as 'a
   648: 
   649: RECURSION CYCLE:
   650:   bind_type' -> bind_expression'
   651: 
   652: TRAP NOTES:
   653:   idx_fixlist and expr_fixlist are related :(
   654: 
   655:   The expr_fixlist handles an explicit typeof(expr)
   656:   term, for an arbitrary expr term.
   657: 
   658:   idx_fixlist is initiated by typeofindex, and only
   659:   occurs typing a variable or function from its
   660:   declaration when the declaration is omitted
   661:   OR when cal_ret_type is verifying it
   662: 
   663: BUG: cal_ret_type is used to verify or compute function
   664: return types. However the equivalent for variables
   665: exists, even uninitialised ones. The two cases
   666: should be handled similarly, if not by the same
   667: routine.
   668: 
   669: Note it is NOT a error for a cycle to occur, even
   670: in the (useless) examples:
   671: 
   672:    val x = x;
   673:    var x = x;
   674: 
   675: In the first case, the val simply might not be used.
   676: In the second case, there may be an assignment.
   677: For a function, a recursive call is NOT an error
   678: for the same reason: a function may
   679: contain other calls, or be unused:
   680:   fun f(x:int)= { return if x = 0 then 0 else f (x-1); }
   681: Note two branches, the first determines the return type
   682: as 'int' quite happily.
   683: 
   684: DEPTH:
   685:   Depth is used to determine the argument of the
   686:   fixpoint term.
   687: 
   688:   Depth is incremented when we decode a type
   689:   or expression into subterms.
   690: 
   691: PROPAGATION.
   692: It appears as_fixlist can only occur
   693: binding a type expression, and doesn't propagate
   694: into bind_expression when a typeof() term is
   695: part of the type expression: it's pure a syntactic
   696: feature of a localised type expression.
   697: 
   698:   typedef t = a * typeof(x) as a;
   699:   var x : t;
   700: 
   701: This is NOT the case, for example:
   702: 
   703:   typedef t = a * typeof (f of (a)) as a;
   704: 
   705: shows the as_fixlist label has propagated into
   706: the expression: expressions can contain type
   707: terms. However, the 'as' label IS always
   708: localised to a single term.
   709: 
   710: Clearly, the same thing can happen with a type alias:
   711: 
   712:   typedef a = a * typeof (f of (a));
   713: 
   714: However, type aliases are more general because they
   715: can span statement boundaries:
   716: 
   717:   typedef a = a * typeof (f of (b));
   718:   typedef b = a;
   719: 
   720: Of course, it comes to the same thing after
   721: substitution .. but lookup and binding is responsible
   722: for that. The key distinction is that an as label
   723: is just a string, whereas a type alias name has
   724: an index in the symtab, and a fully qualified name
   725: can be used to look it up: it's identifid by
   726: its index, not a string label: OTOH non-top level
   727: as labels don't map to any index.
   728: 
   729: NASTY CASE: It's possible to have this kind of thing:
   730: 
   731:   typedef a = typeof ( { typedef b = a; return x; } )
   732: 
   733: so that a type_alias CAN indeed be defined inside a type
   734: expression. That alias can't escape however. In fact,
   735: desugaring restructures this with a lambda (or should):
   736: 
   737:   typedef a = typeof (f of ());
   738:   fun f() { typedef b = a; return x; }
   739: 
   740: This should work BUT if an as_label is propagated
   741: we get a failure:
   742: 
   743:   typedef a = typeof ( { typedef c = b; return x; } ) as b;
   744: 
   745: This can be made to work by lifting the as label too,
   746: which means creating a typedef. Hmmm. All as labels
   747: could be replaced by typedefs ..
   748: 
   749: 
   750: MORE NOTES:
   751: Each of these traps is used to inject a fixpoint
   752: term into the expression, ensuring analysis terminates
   753: and recursions are represented in typing.
   754: 
   755: It is sometimes a bit tricky to know when to pass, and when
   756: to reset these detectors: in bind_type' and inner
   757: bind_type of a subterm should usually pass the detectors
   758: with a pushed value in appropriate cases, however and
   759: independent typing, say of an instance index value,
   760: should start with reset traps.
   761: 
   762: *)
   763: 
   764: (*
   765:   we match type patterns by cheating a bit:
   766:   we convert the pattern to a type, replacing
   767:   the _ with a dummy type variable. We then
   768:   record the 'as' terms of the pattern as a list
   769:   of equations with the as variable index
   770:   on the left, and the type term on the right:
   771:   the RHS cannot contain any as variables.
   772: 
   773:   The generated type can contain both,
   774:   but we can factor the as variables out
   775:   and leave the type a function of the non-as
   776:   pattern variables
   777: *)
   778: 
   779: (* params is list of string * bound type *)
   780: 
   781: and bind_type'
   782:   syms env (rs:recstop)
   783:   sr t (params: (string * btypecode_t) list)
   784:   mkenv
   785: : btypecode_t =
   786:   let st x = st syms.dfns x in
   787:   let btp t params = bind_type' syms env
   788:     {rs with depth = rs.depth+1}
   789:     sr t params mkenv
   790:   in
   791:   let bt t = btp t params in
   792:   let bi i ts = bind_type_index syms rs sr i ts mkenv in
   793:   let bisub i ts = bind_type_index syms {rs with depth= rs.depth+1} sr i ts mkenv in
   794:   (*
   795:   print_endline ("[bind_type'] " ^ string_of_typecode t);
   796:   print_endline ("expr_fixlist is " ^
   797:     catmap ","
   798:     (fun (e,d) -> string_of_expr e ^ " [depth " ^si d^"]")
   799:     expr_fixlist
   800:   );
   801: 
   802:   if length params <> 0 then
   803:   begin
   804:     print_endline ("  [" ^
   805:     catmap ", "
   806:     (fun (s,t) -> s ^ " -> " ^ sbt syms.dfns t)
   807:     params
   808:     ^ "]"
   809:     )
   810:   end
   811:   else print_endline  ""
   812:   ;
   813:   *)
   814:   let t =
   815:   match t with
   816:   | `AST_patvar _ -> failwith "Not implemented patvar in typecode"
   817:   | `AST_patany _ -> failwith "Not implemented patany in typecode"
   818: 
   819:   | `TYP_intersect ts -> `BTYP_intersect (map bt ts)
   820:   | `TYP_record ts -> `BTYP_record (map (fun (s,t) -> s,bt t) ts)
   821:   | `TYP_variant ts -> `BTYP_variant (map (fun (s,t) -> s,bt t) ts)
   822:   | `TYP_lift t -> `BTYP_lift (bt t)
   823: 
   824:   (* We first attempt to perform the match
   825:     at binding time as an optimisation, if that
   826:     fails, we generate a delayed matching construction.
   827:     The latter will be needed when the argument is a type
   828:     variable.
   829:   *)
   830:   | `TYP_type_match (t,ps) ->
   831:     let t = bt t in
   832:     (*
   833:     print_endline ("Typematch " ^ sbt syms.dfns t);
   834:     print_endline ("Context " ^ catmap "" (fun (n,t) -> "\n"^ n ^ " -> " ^ sbt syms.dfns t) params);
   835:     *)
   836:     let pts = ref [] in
   837:     let finished = ref false in
   838:     iter
   839:     (fun (p',t') ->
   840:       (*
   841:       print_endline ("Considering case " ^ string_of_tpattern p' ^ " -> " ^ string_of_typecode t');
   842:       *)
   843:       let p',explicit_vars,any_vars, as_vars, eqns = type_of_tpattern syms p' in
   844:       let p' = bt p' in
   845:       let eqns = map (fun (j,t) -> j, bt t) eqns in
   846:       let varset =
   847:         let x =
   848:           fold_left (fun s (i,_) -> IntSet.add i s)
   849:           IntSet.empty explicit_vars
   850:         in
   851:           fold_left (fun s i -> IntSet.add i s)
   852:           x any_vars
   853:       in
   854:       (* HACK! GACK! we have to assume a variable in a pattern is
   855:         is a TYPE variable .. type patterns don't include coercion
   856:         terms at the moment, so there isn't any way to even
   857:         specify the metatype
   858: 
   859:         In some contexts the kinding can be infered, for example:
   860: 
   861:         int * ?x
   862: 
   863:         clearly x has to be a type .. but a lone type variable
   864:         would require the argument typing to be known ... no
   865:         notation for that yet either
   866:       *)
   867:       let args = map (fun (i,s) ->
   868:       (*
   869:       print_endline ("Mapping " ^ s ^ "<"^si i^"> to TYPE");
   870:       *)
   871:       s,`BTYP_var (i,`BTYP_type 0)) (explicit_vars @ as_vars)
   872:       in
   873:       let t' = btp t' (params@args) in
   874:       let t' = list_subst eqns t' in
   875:       (*
   876:         print_endline ("Bound matching is " ^ sbt syms.dfns p' ^ " => " ^ sbt syms.dfns t');
   877:       *)
   878:       pts := ({pattern=p'; pattern_vars=varset; assignments=eqns},t') :: !pts;
   879:       let u = maybe_unification syms.dfns [p', t] in
   880:       match u with
   881:       | None ->  ()
   882:         (* CRAP! The below argument is correct BUT ..
   883:         our unification algorithm isn't strong enough ...
   884:         so just let this thru and hope it is reduced
   885:         later on instantiation
   886:         *)
   887:         (* If the initially bound, context free pattern can never
   888:         unify with the argument, we have a choice: chuck an error,
   889:         or just eliminate the match case -- I'm going to chuck
   890:         an error for now, because I don't see why one would
   891:         ever code such a case, except as a mistake.
   892:         *)
   893:         (*
   894:         clierr sr
   895:           ("[bind_type'] type match argument\n" ^
   896:           sbt syms.dfns t ^
   897:           "\nwill never unify with pattern\n" ^
   898:           sbt syms.dfns p'
   899:           )
   900:         *)
   901:       | Some mgu ->
   902:         if !finished then
   903:           print_endline "[bind_type] Warning: useless match case ignored"
   904:         else
   905:           let mguvars = fold_left (fun s (i,_) -> IntSet.add i s) IntSet.empty mgu in
   906:           if varset = mguvars then finished := true
   907:     )
   908:     ps
   909:     ;
   910:     let pts = rev !pts in
   911: 
   912:     let tm = `BTYP_type_match (t,pts) in
   913:     (*
   914:     print_endline ("Bound typematch is " ^ sbt syms.dfns tm);
   915:     *)
   916:     tm
   917: 
   918: 
   919:   | `TYP_dual t ->
   920:     let t = bt t in
   921:     dual t
   922: 
   923:   | `TYP_proj (i,t) ->
   924:     let t = bt t in
   925:     ignore (try unfold syms.dfns t with _ -> failwith "TYP_proj unfold screwd");
   926:     begin match unfold syms.dfns t with
   927:     | `BTYP_tuple ls ->
   928:       if i < 1 or i>length ls
   929:       then
   930:        clierr sr
   931:         (
   932:           "product type projection index " ^
   933:           string_of_int i ^
   934:           " out of range 1 to " ^
   935:           string_of_int (length ls)
   936:         )
   937:       else nth ls (i-1)
   938: 
   939:     | _ ->
   940:       clierr sr
   941:       (
   942:         "\ntype projection requires product type"
   943:       )
   944:     end
   945: 
   946:   | `TYP_dom t ->
   947:     let t = bt t in
   948:     begin match unfold syms.dfns t with
   949:     | `BTYP_function (a,b) -> a
   950:     | `BTYP_cfunction (a,b) -> a
   951:     | _ ->
   952:       clierr sr
   953:       (
   954:         short_string_of_src sr ^
   955:         "\ntype domain requires function"
   956:       )
   957:     end
   958:   | `TYP_cod t ->
   959:     let t = bt t in
   960:     begin match unfold syms.dfns t with
   961:     | `BTYP_function (a,b) -> b
   962:     | `BTYP_cfunction (a,b) -> b
   963:     | _ ->
   964:       clierr sr
   965:       (
   966:         short_string_of_src sr ^
   967:         "\ntype codomain requires function"
   968:       )
   969:     end
   970: 
   971:   | `TYP_case_arg (i,t) ->
   972:     let t = bt t in
   973:     ignore (try unfold syms.dfns t with _ -> failwith "TYP_case_arg unfold screwd");
   974:     begin match unfold syms.dfns t with
   975:     | `BTYP_unitsum k ->
   976:       if i < 0 or i >= k
   977:       then
   978:         clierr sr
   979:         (
   980:           "sum type extraction index " ^
   981:           string_of_int i ^
   982:           " out of range 0 to " ^ si (k-1)
   983:         )
   984:       else unit_t
   985: 
   986:     | `BTYP_sum ls ->
   987:       if i < 0 or i>= length ls
   988:       then
   989:         clierr sr
   990:         (
   991:           "sum type extraction index " ^
   992:           string_of_int i ^
   993:           " out of range 0 to " ^
   994:           string_of_int (length ls - 1)
   995:         )
   996:       else nth ls i
   997: 
   998:     | _ ->
   999:       clierr sr
  1000:       (
  1001:         "sum type extraction requires sum type"
  1002:       )
  1003:     end
  1004: 
  1005: 
  1006:   | `TYP_ellipsis ->
  1007:     failwith "Unexpected `TYP_ellipsis (...) in bind type"
  1008:   | `TYP_none ->
  1009:     failwith "Unexpected `TYP_none in bind type"
  1010: 
  1011:   | `TYP_typeset ts
  1012:   | `TYP_setunion ts ->
  1013:     `BTYP_typeset (expand_typeset (`BTYP_typeset (map bt ts)))
  1014: 
  1015:   | `TYP_setintersection ts -> `BTYP_typesetintersection (map bt ts)
  1016: 
  1017: 
  1018:   | `TYP_isin (elt,tset) ->
  1019:     let elt = bt elt in
  1020:     let tset = bt tset in
  1021:     handle_typeset syms sr elt tset
  1022: 
  1023:   (* HACK .. assume variable is type TYPE *)
  1024:   | `TYP_var i ->
  1025:     (*
  1026:     print_endline ("Fudging metatype of type variable " ^ si i);
  1027:     *)
  1028:     `BTYP_var (i,`BTYP_type 0)
  1029: 
  1030:   | `TYP_as (t,s) ->
  1031:     bind_type' syms env
  1032:     { rs with as_fixlist = (s,rs.depth)::rs.as_fixlist }
  1033:     sr t params mkenv
  1034: 
  1035:   | `TYP_typeof e ->
  1036:     (*
  1037:     print_endline ("Evaluating typeof(" ^ string_of_expr e ^ ")");
  1038:     *)
  1039:     let t =
  1040:       if mem_assq e rs.expr_fixlist
  1041:       then begin
  1042:         (*
  1043:         print_endline "Typeof is recursive";
  1044:         *)
  1045:         let outer_depth = assq e rs.expr_fixlist in
  1046:         let fixdepth = outer_depth -rs.depth in
  1047:         (*
  1048:         print_endline ("OUTER DEPTH IS " ^ string_of_int outer_depth);
  1049:         print_endline ("CURRENT DEPTH " ^ string_of_int rs.depth);
  1050:         print_endline ("FIXPOINT IS " ^ string_of_int fixdepth);
  1051:         *)
  1052:         `BTYP_fix fixdepth
  1053:       end
  1054:       else begin
  1055:         snd(bind_expression' syms env rs e [])
  1056:       end
  1057:     in
  1058:       (*
  1059:       print_endline ("typeof --> " ^ sbt syms.dfns t);
  1060:       *)
  1061:       t
  1062: 
  1063:   | `TYP_array (t1,t2)->
  1064:     let index = match bt t2 with
  1065:     | `BTYP_tuple [] -> `BTYP_unitsum 1
  1066:     | x -> x
  1067:     in
  1068:     `BTYP_array (bt t1, index)
  1069: 
  1070:   | `TYP_tuple ts ->
  1071:     let ts' =map bt ts  in
  1072:     `BTYP_tuple ts'
  1073: 
  1074:   | `TYP_unitsum k ->
  1075:     (match k with
  1076:     | 0 -> `BTYP_void
  1077:     | 1 -> `BTYP_tuple[]
  1078:     | _ -> `BTYP_unitsum k
  1079:     )
  1080: 
  1081:   | `TYP_sum ts ->
  1082:     let ts' = map bt ts  in
  1083:     if all_units ts' then
  1084:       `BTYP_unitsum (length ts)
  1085:     else
  1086:       `BTYP_sum ts'
  1087: 
  1088:   | `TYP_function (d,c) ->
  1089:     let
  1090:       d' = bt d  and
  1091:       c' = bt c
  1092:     in
  1093:       `BTYP_function (bt d, bt c)
  1094: 
  1095:   | `TYP_cfunction (d,c) ->
  1096:     let
  1097:       d' = bt d  and
  1098:       c' = bt c
  1099:     in
  1100:       `BTYP_cfunction (bt d, bt c)
  1101: 
  1102:   | `TYP_pointer t ->
  1103:      let t' = bt t in
  1104:      `BTYP_pointer t'
  1105: 
  1106:   | `TYP_lvalue t -> lvalify (bt t)
  1107: 
  1108:   | `AST_void _ ->
  1109:     `BTYP_void
  1110: 
  1111:   | `TYP_typefun (ps,r,body) ->
  1112:     (*
  1113:     print_endline ("BINDING TYPE FUNCTION " ^ string_of_typecode t);
  1114:     *)
  1115:     let data =
  1116:       rev_map
  1117:       (fun (name,mt) ->
  1118:         name,
  1119:         bt mt,
  1120:         let n = !(syms.counter) in
  1121:         incr (syms.counter);
  1122:         n
  1123:       )
  1124:       ps
  1125:     in
  1126:     let pnames =  (* reverse order .. *)
  1127:       map (fun (n, t, i) ->
  1128:         (*
  1129:         print_endline ("Binding param " ^ n ^ "<" ^ si i ^ "> metatype " ^ sbt syms.dfns t);
  1130:         *)
  1131:         (n,`BTYP_var (i,t))) data
  1132:     in
  1133:     let bbody =
  1134:       (*
  1135:       print_endline (" ... binding body .. " ^ string_of_typecode body);
  1136:       print_endline ("Context " ^ catmap "" (fun (n,t) -> "\n"^ n ^ " -> " ^ sbt syms.dfns t) (pnames @ params));
  1137:       *)
  1138:       bind_type' syms env { rs with depth=rs.depth+1 }
  1139:       sr
  1140:       body (pnames@params) mkenv
  1141:     in
  1142:       let bparams = (* order as written *)
  1143:         rev_map (fun (n,t,i) -> (i,t)) data
  1144:       in
  1145:       (*
  1146:       print_endline "BINDING DONE\n";
  1147:       *)
  1148:       `BTYP_typefun (bparams, bt r, bbody)
  1149: 
  1150:   (* this is much the same as our type function *)
  1151:   | `TYP_case (t1, ls, t2) ->
  1152:     (*
  1153:     print_endline ("BINDING TYPECDE " ^ string_of_typecode t);
  1154:     *)
  1155: 
  1156:     (* the variables *)
  1157:     let typevars =
  1158:       rev_map
  1159:       (fun (name) ->
  1160:         name,
  1161:         `BTYP_type 0,
  1162:         let n = !(syms.counter) in
  1163:         incr (syms.counter);
  1164:         n
  1165:       )
  1166:       ls
  1167:     in
  1168:     let pnames =  (* reverse order .. *)
  1169:       map (fun (n, t, i) ->
  1170:         (*
  1171:         print_endline ("Binding param " ^ n ^ "<" ^ si i ^ "> metatype " ^ sbt syms.dfns t);
  1172:         *)
  1173:         (n,`BTYP_var (i,t))) typevars
  1174:     in
  1175:     let bt1 =
  1176:       (*
  1177:       print_endline (" ... binding body .. " ^ string_of_typecode t1);
  1178:       print_endline ("Context " ^ catmap "" (fun (n,t) -> "\n"^ n ^ " -> " ^ sbt syms.dfns t) (pnames @ params));
  1179:       *)
  1180:       bind_type' syms env { rs with depth=rs.depth+1 }
  1181:       sr
  1182:       t1 (pnames@params) mkenv
  1183:     in
  1184:     let bt2 =
  1185:       (*
  1186:       print_endline (" ... binding body .. " ^ string_of_typecode t2);
  1187:       print_endline ("Context " ^ catmap "" (fun (n,t) -> "\n"^ n ^ " -> " ^ sbt syms.dfns t) (pnames @ params));
  1188:       *)
  1189:       bind_type' syms env { rs with depth=rs.depth+1 }
  1190:       sr
  1191:       t2 (pnames@params) mkenv
  1192:     in
  1193:       let bparams = (* order as written *)
  1194:         rev_map (fun (n,t,i) -> (i,t)) typevars
  1195:       in
  1196:       (*
  1197:       print_endline "BINDING DONE\n";
  1198:       *)
  1199: 
  1200:       (* For the moment .. the argument and return types are
  1201:          all of kind TYPE
  1202:       *)
  1203:       let varset = intset_of_list (map fst bparams) in
  1204:       `BTYP_case (bt1, varset, bt2)
  1205: 
  1206: 
  1207:   | `TYP_apply (`AST_name (_,"_flatten",[]),t2) ->
  1208:     let t2 = bt t2 in
  1209:     begin match t2 with
  1210:     | `BTYP_unitsum a -> t2
  1211:     | `BTYP_sum (`BTYP_sum a :: t) -> `BTYP_sum (fold_left (fun acc b ->
  1212:       match b with
  1213:       | `BTYP_sum b -> acc @ b
  1214:       | `BTYP_void -> acc
  1215:       | _ -> clierr sr "Sum of sums required"
  1216:       ) a t)
  1217: 
  1218:     | `BTYP_sum (`BTYP_unitsum a :: t) -> `BTYP_unitsum (fold_left (fun acc b ->
  1219:       match b with
  1220:       | `BTYP_unitsum b -> acc + b
  1221:       | `BTYP_tuple [] -> acc + 1
  1222:       | `BTYP_void -> acc
  1223:       | _ -> clierr sr "Sum of unitsums required"
  1224:       ) a t)
  1225: 
  1226:     | `BTYP_sum (`BTYP_tuple []  :: t) -> `BTYP_unitsum (fold_left (fun acc b ->
  1227:       match b with
  1228:       | `BTYP_unitsum b -> acc + b
  1229:       | `BTYP_tuple [] -> acc + 1
  1230:       | `BTYP_void -> acc
  1231:       | _ -> clierr sr "Sum of unitsums required"
  1232:       ) 1 t)
  1233: 
  1234:     | _ -> clierr sr ("Cannot flatten type " ^ sbt syms.dfns t2)
  1235:     end
  1236: 
  1237:   | `TYP_apply(#qualified_name_t as qn, t2) ->
  1238:      (*
  1239:      print_endline ("Bind application as type " ^ string_of_typecode t);
  1240:      *)
  1241:      let t2 = bt t2 in
  1242:      (*
  1243:      print_endline ("meta typing argument " ^ sbt syms.dfns t2);
  1244:      *)
  1245:      let sign = metatype syms sr t2 in
  1246:      (*
  1247:      print_endline ("Arg type " ^ sbt syms.dfns t2 ^ " meta type " ^ sbt syms.dfns sign);
  1248:      *)
  1249:      let t =
  1250:        try match qn with
  1251:        | `AST_name (sr,name,[]) ->
  1252:          let t1 = assoc name params in
  1253:          `BTYP_apply(t1,t2)
  1254:        | _ -> raise Not_found
  1255:        with Not_found ->
  1256: 
  1257:        (* Note: parameters etc cannot be found with a qualified name,
  1258:        unless it is a simple name .. which is already handled by
  1259:        the previous case .. so we can drop them .. ?
  1260:        *)
  1261: 
  1262:        (* PROBLEM: we don't know if the term is a type alias
  1263:          or type constructor. The former don't overload ..
  1264:          the latter do .. lookup_type_qn_with_sig is probably
  1265:          the wrong routine .. if it finds a constructor, it
  1266:          seems to return the type of the constructor instead
  1267:          of the actual constructor ..
  1268:        *)
  1269:        (*
  1270:        print_endline ("Lookup type qn " ^ string_of_qualified_name qn ^ " with sig " ^ sbt syms.dfns sign);
  1271:        *)
  1272:        let t1 = lookup_type_qn_with_sig' syms sr sr env
  1273:          {rs with depth=rs.depth+1 } qn [sign]
  1274:        in
  1275:        (*
  1276:        let t1 = bisub j ts in
  1277:        *)
  1278:        (*
  1279:        print_endline ("Result of binding function term is " ^ sbt syms.dfns t1);
  1280:        *)
  1281:        `BTYP_apply (t1,t2)
  1282:      in
  1283:      (*
  1284:      print_endline ("type Application is " ^ sbt syms.dfns t);
  1285:      let t = beta_reduce syms sr t in
  1286:      *)
  1287:      (*
  1288:      print_endline ("after beta reduction is " ^ sbt syms.dfns t);
  1289:      *)
  1290:      t
  1291: 
  1292: 
  1293:   | `TYP_apply (t1,t2) ->
  1294:     let t1 = bt t1 in
  1295:     let t2 = bt t2 in
  1296:     let t = `BTYP_apply (t1,t2) in
  1297:     (*
  1298:     let t = beta_reduce syms sr t in
  1299:     *)
  1300:     t
  1301: 
  1302:   | `TYP_type_tuple ts ->
  1303:     `BTYP_type_tuple (map bt ts)
  1304: 
  1305:   | `TYP_type -> `BTYP_type 0
  1306: 
  1307:   | `AST_name (sr,s,[]) when mem_assoc s rs.as_fixlist ->
  1308:     `BTYP_fix ((assoc s rs.as_fixlist)-rs.depth)
  1309: 
  1310:   | `AST_name (sr,s,[]) when mem_assoc s params ->
  1311:     (*
  1312:     print_endline "Found in assoc list .. ";
  1313:     *)
  1314:     assoc s params
  1315: 
  1316:   | `TYP_glr_attr_type qn ->
  1317:     (*
  1318:     print_string ("[bind_type] Calculating type of glr symbol " ^ string_of_qualified_name qn);
  1319:     *)
  1320:     (* WARNING: we're skipping the recursion stoppers here !! *)
  1321:     let t =
  1322:       match lookup_qn_in_env2' syms env rs qn with
  1323:       | `FunctionEntry ii,[] ->
  1324:         cal_glr_attr_type syms sr (map sye ii)
  1325: 
  1326:       | `NonFunctionEntry i,[] ->
  1327:         begin match Hashtbl.find syms.dfns (sye i) with
  1328:         | {sr=sr; symdef=`SYMDEF_const_ctor (_,ut,_,_)} -> `BTYP_void (* hack *)
  1329:         | {sr=sr; symdef=`SYMDEF_nonconst_ctor (_,_,_,_,argt)} ->
  1330:           cal_glr_attr_type'' syms sr (sye i) argt
  1331:         | _ -> clierr sr "Token must be union constructor"
  1332:         end
  1333:       | _,ts -> clierr sr "GLR symbol can't have type subscripts"
  1334:     in
  1335:       (*
  1336:       print_endline (" .. Calculated: " ^sbt syms.dfns t);
  1337:       *)
  1338:       t
  1339: 
  1340: 
  1341:   | `AST_index (sr,name,index) as x ->
  1342:     (*
  1343:     print_endline ("[bind type] AST_index " ^ string_of_qualified_name x);
  1344:     *)
  1345:     let { vs=vs; symdef=entry } =
  1346:       try Hashtbl.find syms.dfns index
  1347:       with Not_found ->
  1348:         syserr sr ("Synthetic name "^name ^ " not in symbol table!")
  1349:     in
  1350:     begin match entry with
  1351:     | `SYMDEF_struct _
  1352:     | `SYMDEF_cstruct _
  1353:     | `SYMDEF_union _
  1354:     | `SYMDEF_class
  1355:     | `SYMDEF_cclass _
  1356:     | `SYMDEF_abs _
  1357:       ->
  1358:       (*
  1359:       if length (fst vs) <> 0 then begin
  1360:         print_endline ("Synthetic name "^name ^ " is a nominal type!");
  1361:         print_endline ("Using ts = [] .. probably wrong since type is polymorphic!");
  1362:       end
  1363:       ;
  1364:       *)
  1365:       let ts = map (fun (s,i,_) ->
  1366:         (*
  1367:         print_endline ("[Ast_index] fudging type variable " ^ si i);
  1368:         *)
  1369:         `BTYP_var (i,`BTYP_type 0)) (fst vs)
  1370:       in
  1371:       (*
  1372:       print_endline ("Synthetic name "^name ^ "<"^si index^"> is a nominal type, ts=" ^
  1373:       catmap "," (sbt syms.dfns) ts
  1374:       );
  1375:       *)
  1376:       `BTYP_inst (index,ts)
  1377: 
  1378:     | `SYMDEF_typevar _ ->
  1379:       print_endline ("Synthetic name "^name ^ " is a typevar!");
  1380:       syserr sr ("Synthetic name "^name ^ " is a typevar!")
  1381: 
  1382:     | _
  1383:       ->
  1384:         print_endline ("Synthetic name "^name ^ " is not a nominal type!");
  1385:         syserr sr ("Synthetic name "^name ^ " is not a nominal type!")
  1386:     end
  1387: 
  1388:   (* QUALIFIED OR UNQUALIFIED NAME *)
  1389:   | `AST_the (sr,qn) ->
  1390:     (*
  1391:     print_endline ("[bind_type] Matched THE qualified name " ^ string_of_qualified_name qn);
  1392:     *)
  1393:     let es,ts = lookup_qn_in_env2' syms env rs qn in
  1394:     begin match es with
  1395:     | `FunctionEntry [index] ->
  1396:        let ts = map bt ts in
  1397:        let f =  bi (sye index) ts in
  1398:        (*
  1399:        print_endline ("f = " ^ sbt syms.dfns f);
  1400:        *)
  1401:        f
  1402: 
  1403:        (*
  1404:        `BTYP_typefun (params, ret, body)
  1405: 
  1406: 
  1407:        of (int * 't) list * 't * 't
  1408:        *)
  1409:        (*
  1410:        failwith "TYPE FUNCTION CLOSURE REQUIRED!"
  1411:        *)
  1412:        (*
  1413:        `BTYP_typefun_closure (sye index, ts)
  1414:        *)
  1415: 
  1416:     | `NonFunctionEntry index  ->
  1417:       let {id=id; vs=vs; sr=sr;symdef=entry} = Hashtbl.find syms.dfns (sye index) in
  1418:       (*
  1419:       print_endline ("NON FUNCTION ENTRY " ^ id);
  1420:       *)
  1421:       begin match entry with
  1422:       | `SYMDEF_type_alias t ->
  1423:         (* This is HACKY but probably right most of the time: we're defining
  1424:            "the t" where t is parameterised type as a type function accepting
  1425:            all the parameters and returning a type .. if the result were
  1426:            actually a functor this would be wrong .. you'd need to say
  1427:            "the (the t)" to bind the domain of the returned functor ..
  1428:         *)
  1429:         (* NOTE THIS STUFF IGNORES THE VIEW AT THE MOMENT *)
  1430:         let ivs,traint = vs in
  1431:         let bmt mt =
  1432:           match mt with
  1433:           | `AST_patany _ -> `BTYP_type 0 (* default *)
  1434:           | _ -> (try bt mt with _ -> clierr sr "metatyp binding FAILED")
  1435:         in
  1436:         let body =
  1437:           let env = mkenv (sye index) in
  1438:           let xparams = map (fun (id,idx,mt) -> id, `BTYP_var (idx, bmt mt)) ivs in
  1439:           bind_type' syms env {rs with depth = rs.depth+1} sr t (xparams @ params) mkenv
  1440:         in
  1441:         let ret = `BTYP_type 0 in
  1442:         let params = map (fun (id,idx,mt) -> idx, bmt mt) ivs in
  1443:         `BTYP_typefun (params, ret, body)
  1444: 
  1445:       | _ ->
  1446:         let ts = map bt ts in
  1447:         bi (sye index) ts
  1448:       end
  1449: 
  1450:     | _ -> clierr sr
  1451:       "'the' expression denotes non-singleton function set"
  1452:     end
  1453: 
  1454:   | #qualified_name_t as x ->
  1455:     (*
  1456:     print_endline ("[bind_type] Matched qualified name " ^ string_of_qualified_name x);
  1457:     *)
  1458:     if env = [] then print_endline "WOOPS EMPTY ENVIRONMENT!";
  1459: 
  1460:     begin match lookup_qn_in_env syms env x with
  1461:     | i,ts ->
  1462:       let ts = map bt ts in
  1463:       (*
  1464:       print_endline ("Qualified name lookup finds index " ^ si (sye i) ^
  1465:       "[" ^ catmap "," (sbt syms.dfns) ts ^ "]");
  1466:       *)
  1467:       bi (sye i) ts
  1468:     end
  1469: 
  1470:   | `AST_suffix (sr,(qn,t)) ->
  1471:     let sign = bt t in
  1472:     let result =
  1473:       lookup_qn_with_sig' syms  sr sr env rs qn [sign]
  1474:     in
  1475:     begin match result with
  1476:     | `BEXPR_closure (i,ts),_ ->
  1477:       bi i ts
  1478:     | _  -> clierr sr
  1479:       (
  1480:         "[typecode_of_expr] Type expected, got: " ^
  1481:         sbe syms.dfns result
  1482:       )
  1483:     end
  1484:   in
  1485:     (*
  1486:     print_endline ("Bound type is " ^ sbt syms.dfns t);
  1487:     *)
  1488:     t
  1489: 
  1490: and cal_glr_attr_type'' syms sr (i:int) t =
  1491:   try Hashtbl.find syms.glr_cache i
  1492:   with Not_found ->
  1493:   try Hashtbl.find syms.varmap i
  1494:   with Not_found ->
  1495:   match t with
  1496:   | `TYP_none -> `BTYP_var (i,`BTYP_type 0)
  1497:   | _ ->
  1498:     let env = build_env syms (Some i) in
  1499:     let t = bind_type syms env sr t in
  1500:     Hashtbl.add syms.glr_cache i t;
  1501:     Hashtbl.add syms.varmap i t;
  1502:     t
  1503: 
  1504: and cal_glr_attr_type' syms sr i =
  1505:   match Hashtbl.find syms.dfns i with
  1506:   | {symdef=`SYMDEF_glr (t,_)} ->
  1507:     `Nonterm,cal_glr_attr_type'' syms sr i t
  1508: 
  1509:   | {symdef=`SYMDEF_nonconst_ctor (_,_,_,_,t)} ->
  1510:     `Term, cal_glr_attr_type'' syms sr i t
  1511: 
  1512:   (* shouldn't happen .. *)
  1513:   | {symdef=`SYMDEF_const_ctor (_,_,_,_)} ->
  1514:     `Term, `BTYP_void
  1515: 
  1516:   | {id=id;symdef=symdef} ->
  1517:     clierr sr (
  1518:       "[cal_glr_attr_type'] Expected glr nonterminal or token "^
  1519:       "(union constructor with argument), got\n" ^
  1520:       string_of_symdef symdef id dfltvs
  1521:     )
  1522: 
  1523: and cal_glr_attr_type syms sr ii =
  1524:   let idof i = match Hashtbl.find syms.dfns i with {id=id} -> id in
  1525:   match ii with
  1526:   | [] -> syserr sr "Unexpected empty FunctonEntry"
  1527:   | h :: tts ->
  1528:     let kind,t = cal_glr_attr_type' syms sr h in
  1529:     iter
  1530:     (fun i ->
  1531:       let kind',t' = cal_glr_attr_type' syms sr i in
  1532:       match kind,kind' with
  1533:       | `Nonterm,`Nonterm
  1534:       | `Term,`Term  ->
  1535:         if not (type_eq syms.dfns t t') then
  1536:         clierr sr
  1537:         ("Expected same type for glr symbols,\n" ^
  1538:           idof h ^ " has type " ^ sbt syms.dfns t ^ "\n" ^
  1539:           idof i ^ " has type " ^ sbt syms.dfns t'
  1540:         )
  1541: 
  1542:       | `Nonterm,`Term -> clierr sr "Expected glr nonterminal argument"
  1543:       | `Term,`Nonterm -> clierr sr "Token: Expected union constructor with argument"
  1544:     )
  1545:     tts
  1546:     ;
  1547:     t
  1548: 
  1549: and cal_assoc_type syms sr t =
  1550:   let ct t = cal_assoc_type syms sr t in
  1551:   let chk ls =
  1552:     match ls with
  1553:     | [] -> `BTYP_void
  1554:     | h::t ->
  1555:       fold_left (fun acc t ->
  1556:         if acc <> t then
  1557:           clierr sr ("[cal_assoc_type] typeset elements should all be assoc type " ^ sbt syms.dfns acc)
  1558:         ;
  1559:         acc
  1560:      ) h t
  1561:   in
  1562:   match t with
  1563:   | `BTYP_type i -> t
  1564:   | `BTYP_function (a,b) -> `BTYP_function (ct a, ct b)
  1565: 
  1566:   | `BTYP_intersect ls
  1567:   | `BTYP_typesetunion ls
  1568:   | `BTYP_typeset ls
  1569:     ->
  1570:     let ls = map ct ls in chk ls
  1571: 
  1572:   | `BTYP_tuple _
  1573:   | `BTYP_record _
  1574:   | `BTYP_variant _
  1575:   | `BTYP_unitsum _
  1576:   | `BTYP_sum _
  1577:   | `BTYP_cfunction _
  1578:   | `BTYP_pointer _
  1579:   | `BTYP_lvalue _
  1580:   | `BTYP_array _
  1581:   | `BTYP_void
  1582:     -> `BTYP_type 0
  1583: 
  1584:   | `BTYP_inst (i,ts) ->
  1585:     (*
  1586:     print_endline ("Assuming named type "^si i^" is a TYPE");
  1587:     *)
  1588:     `BTYP_type 0
  1589: 
  1590: 
  1591:   | `BTYP_type_match (_,ls) ->
  1592:     let ls = map snd ls in
  1593:     let ls = map ct ls in chk ls
  1594: 
  1595:   | _ -> clierr sr ("Don't know what to make of " ^ sbt syms.dfns t)
  1596: 
  1597: and bind_type_index syms (rs:recstop)
  1598:   sr index ts mkenv
  1599: =
  1600:   (*
  1601:   print_endline
  1602:   (
  1603:     "BINDING INDEX " ^ string_of_int index ^
  1604:     " with ["^ catmap ", " (sbt syms.dfns) ts^ "]"
  1605:   );
  1606:   print_endline ("type alias fixlist is " ^ catmap ","
  1607:     (fun (i,j) -> si i ^ "(depth "^si j^")") type_alias_fixlist
  1608:   );
  1609:   *)
  1610:   if mem_assoc index rs.type_alias_fixlist
  1611:   then begin
  1612:     (*
  1613:     print_endline (
  1614:       "Making fixpoint for Recursive type alias " ^
  1615:       (
  1616:         match get_data syms.dfns index with {id=id;sr=sr}->
  1617:           id ^ " defined at " ^
  1618:           short_string_of_src sr
  1619:       )
  1620:     );
  1621:     *)
  1622:     `BTYP_fix ((assoc index rs.type_alias_fixlist)-rs.depth)
  1623:   end
  1624:   else begin
  1625:   (*
  1626:   print_endline "bind_type_index";
  1627:   *)
  1628:   let ts = adjust_ts syms sr index ts in
  1629:   (*
  1630:   print_endline ("Adjusted ts =h ["^ catmap ", " (sbt syms.dfns) ts^ "]");
  1631:   *)
  1632:   let bt t =
  1633:       (*
  1634:       print_endline "Making params .. ";
  1635:       *)
  1636:       let vs,_ = find_vs syms index in
  1637:       if length vs <> length ts then begin
  1638:         print_endline ("vs=" ^ catmap "," (fun (s,i,_)-> s^"<"^si i^">") vs);
  1639:         print_endline ("ts=" ^ catmap "," (sbt syms.dfns) ts);
  1640:         failwith "len vs != len ts"
  1641:       end
  1642:       else
  1643:       let params = map2 (fun (s,i,_) t -> s,t) vs ts in
  1644: 
  1645:       (*
  1646:       let params = make_params syms sr index ts in
  1647:       *)
  1648:       (*
  1649:       print_endline ("params made");
  1650:       *)
  1651:       let env:env_t = mkenv index in
  1652:       let t =
  1653:         bind_type' syms env
  1654:         { rs with type_alias_fixlist = (index,rs.depth):: rs.type_alias_fixlist }
  1655:         sr t params mkenv
  1656:       in
  1657:         (*
  1658:         print_endline ("Unravelled and bound is " ^ sbt syms.dfns t);
  1659:         *)
  1660:         (*
  1661:         let t = beta_reduce syms sr t in
  1662:         *)
  1663:         (*
  1664:         print_endline ("Beta reduced: " ^ sbt syms.dfns t);
  1665:         *)
  1666:         t
  1667:   in
  1668:   match get_data syms.dfns index with
  1669:   | {id=id;sr=sr;parent=parent;vs=vs;pubmap=tabl;dirs=dirs;symdef=entry} ->
  1670:     (*
  1671:     if length vs <> length ts
  1672:     then
  1673:       clierr sr
  1674:       (
  1675:         "[bind_type_index] Wrong number of type arguments for " ^ id ^
  1676:         ", expected " ^
  1677:         si (length vs) ^ " got " ^ si (length ts)
  1678:       );
  1679:     *)
  1680:     match entry with
  1681:     | `SYMDEF_typevar mt ->
  1682:       (* HACK! We will assume metatype are entirely algebraic,
  1683:         that is, they cannot be named and referenced, we also
  1684:         assume they cannot be subscripted .. the bt routine
  1685:         that works for type aliases doesn't seem to work for
  1686:         metatypes .. we get vs != ts .. ts don't make sense
  1687:         for type variables, only for named things ..
  1688:       *)
  1689:       (* WELL the above is PROBABLY because we're calling
  1690:       this routine using sye function to strip the view,
  1691:       so the supplied ts are wrong ..
  1692:       *)
  1693:       (*
  1694:       print_endline ("CALCULATING TYPE VARIABLE METATYPE " ^ si index ^ " unbound=" ^ string_of_typecode mt);
  1695:       *)
  1696:       (* weird .. a type variables parent function has an env containing
  1697:       the type variable .. so we need ITS parent for resolving the
  1698:       meta type ..??
  1699: 
  1700:       No? We STILL get an infinite recursion???????
  1701:       *)
  1702:       (*
  1703:       print_endline ("type variable index " ^ si index);
  1704:       *)
  1705:       let env = match parent with
  1706:         | Some parent ->
  1707:           (*
  1708:           print_endline ("It's parent is " ^ si parent);
  1709:           *)
  1710:           (*
  1711:           let {parent=parent} = Hashtbl.find syms.dfns parent in
  1712:           begin match parent with
  1713:           | Some parent ->
  1714:              print_endline ("and IT's parent is " ^ si parent);
  1715:           *)
  1716:             let mkenv i = mk_bare_env syms i in
  1717:             mkenv parent
  1718:           (*
  1719:           | None -> []
  1720:           end
  1721:           *)
  1722:         | None -> []
  1723:       in
  1724:       let mt = bind_type syms env sr mt in
  1725:       (*
  1726:       print_endline ("Bound metatype is " ^ sbt syms.dfns mt);
  1727:       let mt = cal_assoc_type syms sr mt in
  1728:       print_endline ("Assoc type is " ^ sbt syms.dfns mt);
  1729:       *)
  1730:       `BTYP_var (index,mt)
  1731: 
  1732:     (* type alias RECURSE *)
  1733:     | `SYMDEF_type_alias t ->
  1734:       (*
  1735:       print_endline ("Unravelling type alias " ^ id);
  1736:       *)
  1737:       bt t
  1738: 
  1739:     | `SYMDEF_abs _ ->
  1740:       `BTYP_inst (index,ts)
  1741: 
  1742:     | `SYMDEF_newtype _
  1743:     | `SYMDEF_union _
  1744:     | `SYMDEF_struct _
  1745:     | `SYMDEF_cstruct _
  1746:     | `SYMDEF_class
  1747:     | `SYMDEF_cclass _
  1748:     | `SYMDEF_typeclass
  1749:       ->
  1750:       `BTYP_inst (index,ts)
  1751: 
  1752: 
  1753:     (* allow binding to type constructors now too .. *)
  1754:     | `SYMDEF_const_ctor (uidx,ut,idx,vs') ->
  1755:       `BTYP_inst (index,ts)
  1756: 
  1757:     | `SYMDEF_nonconst_ctor (uidx,ut,idx,vs',argt) ->
  1758:       `BTYP_inst (index,ts)
  1759: 
  1760:     | _ ->
  1761:       clierr sr
  1762:       (
  1763:         "[bind_type_index] Type " ^ id ^ "<" ^ si index ^ ">" ^
  1764:         " must be a type [alias, abstract, union, struct], got:\n" ^
  1765:         string_of_symdef entry id vs
  1766:       )
  1767:   end
  1768: 
  1769: 
  1770: and base_typename_of_literal v = match v with
  1771:   | `AST_int (t,_) -> t
  1772:   | `AST_float (t,_) -> t
  1773:   | `AST_string _ -> "string"
  1774:   | `AST_cstring _ -> "charp"
  1775:   | `AST_wstring _ -> "wstring"
  1776:   | `AST_ustring _ -> "string"
  1777: 
  1778: and  typeof_literal syms env sr v : btypecode_t =
  1779:   let _,_,root,_ = hd (rev env) in
  1780:   let name = base_typename_of_literal v in
  1781:   let t = `AST_name (sr,name,[]) in
  1782:   let bt = bind_type syms env sr t in
  1783:   bt
  1784: 
  1785: and typeofindex_with_ts
  1786:   syms sr
  1787:   (index:int)
  1788:   ts
  1789: =
  1790:   (*
  1791:   print_endline "OUTER TYPE OF INDEX with TS";
  1792:   *)
  1793:   let t = typeofindex syms index in
  1794:   let varmap = make_varmap syms sr index ts in
  1795:   let t = varmap_subst varmap t in
  1796:   beta_reduce syms sr t
  1797: 
  1798: (* This routine should ONLY 'fail' if the return type
  1799:   is indeterminate. This cannot usually happen.
  1800: 
  1801:   Otherwise, the result may be recursive, possibly
  1802:   Fix 0 -- which is determinate 'indeterminate' value :-)
  1803: 
  1804:   For example: fun f(x:int) { return f x; }
  1805: 
  1806:   should yield fix 0, and NOT fail.
  1807: *)
  1808: 
  1809: 
  1810: (* cal_ret_type uses the private name map *)
  1811: (* args is string,btype list *)
  1812: and cal_ret_type syms (rs:recstop) index args =
  1813:   (*
  1814:   print_endline ("[cal_ret_type] index " ^ si index);
  1815:   print_endline ("expr_fixlist is " ^
  1816:     catmap ","
  1817:     (fun (e,d) -> string_of_expr e ^ " [depth " ^si d^"]")
  1818:     rs.expr_fixlist
  1819:   );
  1820:   *)
  1821:   let mkenv i = build_env syms (Some i) in
  1822:   let env = mkenv index in
  1823:   (*
  1824:   print_env_short env;
  1825:   *)
  1826:   match (get_data syms.dfns index) with
  1827:   | {id=id;sr=sr;parent=parent;vs=vs;privmap=name_map;dirs=dirs;
  1828:      symdef=`SYMDEF_function ((ps,_),rt,props,exes)
  1829:     } ->
  1830:     (*
  1831:     print_endline ("Calculate return type of " ^ id);
  1832:     *)
  1833:     let rt = bind_type' syms env rs sr rt args mkenv in
  1834:     let rt = beta_reduce syms sr rt in
  1835:     let ret_type = ref rt in
  1836:     (*
  1837:     begin match rt with
  1838:     | `BTYP_var (i,_) when i = index ->
  1839:       print_endline "No return type given"
  1840:     | _ ->
  1841:       print_endline (" .. given type is " ^ sbt syms.dfns rt)
  1842:     end
  1843:     ;
  1844:     *)
  1845:     let return_counter = ref 0 in
  1846:     iter
  1847:     (fun exe -> match exe with
  1848:     | (sr,`EXE_fun_return e) ->
  1849:       incr return_counter;
  1850:       (*
  1851:       print_endline ("  .. Handling return of " ^ string_of_expr e);
  1852:       *)
  1853:       begin try
  1854:         let t =
  1855:           (* this is bad code .. we lose detection
  1856:           of errors other than recursive dependencies ..
  1857:           which shouldn't be errors anyhow ..
  1858:           *)
  1859:             snd
  1860:             (
  1861:               bind_expression' syms env
  1862:               { rs with idx_fixlist = index::rs.idx_fixlist }
  1863:               e []
  1864:             )
  1865:         in
  1866:         if do_unify syms !ret_type t (* the argument order is crucial *)
  1867:         then
  1868:           ret_type := varmap_subst syms.varmap !ret_type
  1869:         else begin
  1870:           (*
  1871:           print_endline
  1872:           (
  1873:             "[cal_ret_type2] Inconsistent return type of " ^ id ^ "<"^string_of_int index^">" ^
  1874:             "\nGot: " ^ sbt syms.dfns !ret_type ^
  1875:             "\nAnd: " ^ sbt syms.dfns t
  1876:           )
  1877:           ;
  1878:           *)
  1879:           clierr sr
  1880:           (
  1881:             "[cal_ret_type2] Inconsistent return type of " ^ id ^ "<"^string_of_int index^">" ^
  1882:             "\nGot: " ^ sbt syms.dfns !ret_type ^
  1883:             "\nAnd: " ^ sbt syms.dfns t
  1884:           )
  1885:         end
  1886:       with
  1887:         | Stack_overflow -> failwith "[cal_ret_type] Stack overflow"
  1888:         | Expr_recursion e -> ()
  1889:         | Free_fixpoint t -> ()
  1890:         | Unresolved_return (sr,s) -> ()
  1891:         | ClientError (sr,s) as e -> raise (ClientError (sr,"Whilst calculating return type:\n"^s))
  1892:         | x ->
  1893:         (*
  1894:         print_endline ("  .. Unable to compute type of " ^ string_of_expr e);
  1895:         print_endline ("Reason: " ^ Printexc.to_string x);
  1896:         *)
  1897:         ()
  1898:       end
  1899:     | _ -> ()
  1900:     )
  1901:     exes
  1902:     ;
  1903:     if !return_counter = 0 then (* it's a procedure .. *)
  1904:     begin
  1905:       let mgu = do_unify syms !ret_type `BTYP_void in
  1906:       ret_type := varmap_subst syms.varmap !ret_type
  1907:     end
  1908:     ;
  1909:     (* not sure if this is needed or not ..
  1910:       if a type variable is computed during evaluation,
  1911:       but the evaluation fails .. substitute now
  1912:     ret_type := varmap_subst syms.varmap !ret_type
  1913:     ;
  1914:     *)
  1915:     (*
  1916:     let ss = ref "" in
  1917:     Hashtbl.iter
  1918:     (fun i t -> ss:=!ss ^si i^ " --> " ^sbt syms.dfns t^ "\n")
  1919:     syms.varmap;
  1920:     print_endline ("syms.varmap=" ^ !ss);
  1921:     print_endline ("  .. ret type index " ^ si index ^ " = " ^ sbt syms.dfns !ret_type);
  1922:     *)
  1923:     !ret_type
  1924: 
  1925:   | _ -> assert false
  1926: 
  1927: 
  1928: and inner_typeofindex_with_ts
  1929:   syms sr (rs:recstop)
  1930:   (index:int)
  1931:   (ts: btypecode_t list)
  1932: : btypecode_t =
  1933:  (*
  1934:  print_endline ("Inner type of index with ts .. " ^ si index ^ ", ts=" ^ catmap "," (sbt syms.dfns) ts);
  1935:  *)
  1936:  let t = inner_typeofindex syms rs index in
  1937:  let pvs,vs,_ = find_split_vs syms index in
  1938:  (*
  1939:  print_endline ("#pvs=" ^ si (length pvs) ^ ", #vs="^si (length vs) ^", #ts="^
  1940:  si (length ts));
  1941:  *)
  1942:  (*
  1943:  let ts = adjust_ts syms sr index ts in
  1944:  print_endline ("#adj ts = " ^ si (length ts));
  1945:  let vs,_ = find_vs syms index in
  1946:  assert (length vs = length ts);
  1947:  *)
  1948:  if (length ts != length vs + length pvs) then
  1949:    print_endline ("#ts != #vs + #pvs")
  1950:  ;
  1951:  assert (length ts = length vs + length pvs);
  1952:  let varmap = make_varmap syms sr index ts in
  1953:  let t = varmap_subst varmap t in
  1954:  let t = beta_reduce syms sr t in
  1955:  (*
  1956:  print_endline ("typeofindex=" ^ sbt syms.dfns t);
  1957:  *)
  1958:  t
  1959: 
  1960: 
  1961: (* this routine is called to find the type of a function
  1962: or variable .. so there's no type_alias_fixlist ..
  1963: *)
  1964: 
  1965: and typeofindex
  1966:   syms
  1967:   (index:int)
  1968: : btypecode_t =
  1969:     (*
  1970:     let () = print_endline ("Top level type of index " ^ si index) in
  1971:     *)
  1972:     if Hashtbl.mem syms.ticache index
  1973:     then begin
  1974:       let t = Hashtbl.find syms.ticache index in
  1975:       (*
  1976:       let () = print_endline ("Cached .." ^ sbt syms.dfns t) in
  1977:       *)
  1978:       t
  1979:     end
  1980:     else
  1981:       let t = inner_typeofindex syms rsground index in
  1982:       let _ = try unfold syms.dfns t with _ ->
  1983:         print_endline "typeofindex produced free fixpoint";
  1984:         failwith ("[typeofindex] free fixpoint constructed for " ^ sbt syms.dfns t)
  1985:       in
  1986:       let sr = try
  1987:         match Hashtbl.find syms.dfns index with {sr=sr}-> sr
  1988:         with Not_found -> dummy_sr
  1989:       in
  1990:       let t = beta_reduce syms sr t in
  1991:       (*
  1992:       print_endline ("Type of index "^ si index ^ " is " ^ sbt syms.dfns t);
  1993:       *)
  1994:       (match t with (* HACK .. *)
  1995:       | `BTYP_fix _ -> ()
  1996:       | _ -> Hashtbl.add syms.ticache index t
  1997:       );
  1998:       t
  1999: 
  2000: and inner_typeofindex
  2001:   syms (rs:recstop)
  2002:   (index:int)
  2003: : btypecode_t =
  2004:   (*
  2005:   print_endline ("[inner_type_of_index] " ^ si index);
  2006:   print_endline ("expr_fixlist is " ^
  2007:     catmap ","
  2008:     (fun (e,d) -> string_of_expr e ^ " [depth " ^si d^"]")
  2009:     rs.expr_fixlist
  2010:   );
  2011:   *)
  2012:   (* check the cache *)
  2013:   try Hashtbl.find syms.ticache index
  2014:   with Not_found ->
  2015: 
  2016:   (* check index recursion *)
  2017:   if mem index rs.idx_fixlist
  2018:   then `BTYP_fix (-rs.depth)
  2019:   else begin
  2020:   match get_data syms.dfns index with
  2021:   | {id=id;sr=sr;parent=parent;vs=vs;privmap=table;dirs=dirs;symdef=entry}
  2022:   ->
  2023:   let mkenv i = build_env syms (Some i) in
  2024:   let env:env_t = mkenv index in
  2025:   (*
  2026:   print_endline ("Setting up env for " ^ si index);
  2027:   print_env_short env;
  2028:   *)
  2029:   let bt t:btypecode_t =
  2030:     let t' =
  2031:       bind_type' syms env rs sr t [] mkenv in
  2032:     let t' = beta_reduce syms sr t' in
  2033:     t'
  2034:   in
  2035:   match entry with
  2036:   | `SYMDEF_callback _ -> print_endline "Inner type of index finds callback"; assert false
  2037:   | `SYMDEF_inherit qn -> failwith ("Woops inner_typeofindex found inherit " ^ si index)
  2038:   | `SYMDEF_inherit_fun qn -> failwith ("Woops inner_typeofindex found inherit fun!! " ^ si index)
  2039:   | `SYMDEF_type_alias t ->
  2040:     begin
  2041:       let t = bt t in
  2042:       let mt = metatype syms sr t in
  2043:       (*
  2044:       print_endline ("Type of type alias is meta_type: " ^ sbt syms.dfns mt);
  2045:       *)
  2046:       mt
  2047:     end
  2048: 
  2049:   | `SYMDEF_function ((ps,_), rt,props,_) ->
  2050:     let pts = map (fun(_,_,t)->t) ps in
  2051:     let rt' =
  2052:       try Hashtbl.find syms.varmap index with Not_found ->
  2053:       cal_ret_type syms { rs with idx_fixlist = index::rs.idx_fixlist}
  2054:       index []
  2055:     in
  2056:       (* this really isn't right .. need a better way to
  2057:         handle indeterminate result .. hmm ..
  2058:       *)
  2059:       if var_i_occurs index rt' then begin
  2060:         (*
  2061:         print_endline (
  2062:           "[typeofindex'] " ^
  2063:           "function "^id^"<"^string_of_int index^
  2064:           ">: Can't resolve return type, got : " ^
  2065:           sbt syms.dfns rt' ^
  2066:           "\nPossibly each returned expression depends on the return type" ^
  2067:           "\nTry adding an explicit return type annotation"
  2068:         );
  2069:         *)
  2070:         raise (Unresolved_return (sr,
  2071:         (
  2072:           "[typeofindex'] " ^
  2073:           "function "^id^"<"^string_of_int index^
  2074:           ">: Can't resolve return type, got : " ^
  2075:           sbt syms.dfns rt' ^
  2076:           "\nPossibly each returned expression depends on the return type" ^
  2077:           "\nTry adding an explicit return type annotation"
  2078:         )))
  2079:       end else
  2080:         let d =bt (typeof_list pts) in
  2081:         let t =
  2082:           if mem `Cfun props
  2083:           then `BTYP_cfunction (d,rt')
  2084:           else `BTYP_function (d, rt')
  2085:         in
  2086:         t
  2087: 
  2088:   | `SYMDEF_const (t,_,_)
  2089:   | `SYMDEF_val (t)
  2090:   | `SYMDEF_var (t)
  2091:   | `SYMDEF_ref (t)
  2092:   | `SYMDEF_parameter (`PVal,t)
  2093:   | `SYMDEF_parameter (`PFun,t)
  2094:   | `SYMDEF_const_ctor (_,t,_,_)
  2095:     ->
  2096:     (*
  2097:     print_endline ("Calculating type of variable " ^ id);
  2098:     *)
  2099:     bt t
  2100: 
  2101:   | `SYMDEF_parameter (`PVar,t)
  2102:   | `SYMDEF_parameter (`PRef,t) ->
  2103:     `BTYP_lvalue (bt t)
  2104: 
  2105:   | `SYMDEF_regmatch (ps,cls)
  2106:   | `SYMDEF_reglex (ps,_,cls) ->
  2107:     let be e =
  2108:       bind_expression' syms env
  2109:       { rs with idx_fixlist = index::rs.idx_fixlist }
  2110:       e []
  2111:     in
  2112:     let t = snd (be (snd (hd cls))) in
  2113:     let lexit_t = bt (`AST_lookup (sr,(`AST_name (sr,"Lexer",[]),"iterator",[]))) in
  2114:     `BTYP_function (`BTYP_array (lexit_t,`BTYP_unitsum 2),t)
  2115: 
  2116:   | `SYMDEF_nonconst_ctor (_,ut,_,_,argt) ->
  2117:     bt (`TYP_function (argt,ut))
  2118: 
  2119:   | `SYMDEF_match_check _ ->
  2120:     `BTYP_function (`BTYP_tuple [], flx_bbool)
  2121: 
  2122:   | `SYMDEF_fun (_,pts,rt,_,_,_) ->
  2123:     let t = `TYP_function (typeof_list pts,rt) in
  2124:     bt t
  2125: 
  2126:   | `SYMDEF_union _ ->
  2127:     clierr sr ("Union "^id^" doesn't have a type")
  2128: 
  2129:   (* struct as function *)
  2130:   | `SYMDEF_cstruct (ls)
  2131:   | `SYMDEF_struct (ls) ->
  2132:     (* ARGGG WHAT A MESS *)
  2133:     let ts = map (fun (s,i,_) -> `AST_name (sr,s,[])) (fst vs) in
  2134:     let ts = map bt ts in
  2135:   (*
  2136:   print_endline "inner_typeofindex: struct";
  2137:   *)
  2138:     let ts = adjust_ts syms sr index ts in
  2139:     let t = typeof_list (map snd ls) in
  2140:     let t = `BTYP_function(bt t,`BTYP_inst (index,ts)) in
  2141:     (*
  2142:     print_endline ("Struct as function type is " ^ sbt syms.dfns t);
  2143:     *)
  2144:     t
  2145: 
  2146:   | `SYMDEF_class ->
  2147:     let ts = map (fun (s,i,_) -> `AST_name (sr,s,[])) (fst vs) in
  2148:     let ts = map bt ts in
  2149:     let ts = adjust_ts syms sr index ts in
  2150:     `BTYP_inst (index,ts)
  2151: 
  2152:   | `SYMDEF_abs _ ->
  2153:     clierr sr
  2154:     (
  2155:       "[typeofindex] Expected declaration of typed entity for index " ^
  2156:       string_of_int index ^ "\ngot abstract type " ^ id  ^ " instead.\n" ^
  2157:       "Perhaps a constructor named " ^ "_ctor_" ^ id ^ " is missing " ^
  2158:       " or out of scope."
  2159:     )
  2160: 
  2161:   | _ ->
  2162:     clierr sr
  2163:     (
  2164:       "[typeofindex] Expected declaration of typed entity for index "^
  2165:       string_of_int index^", got " ^ id
  2166:     )
  2167:   end
  2168: 
  2169: and cal_apply syms sr ((be1,t1) as tbe1) ((be2,t2) as tbe2) : tbexpr_t =
  2170:   (*
  2171:   print_endline ("Cal apply of " ^ sbe syms.dfns tbe1 ^ " to " ^ sbe syms.dfns tbe2);
  2172:   *)
  2173:   let ((re,rt) as r) = cal_apply' syms sr tbe1 tbe2 in
  2174:   (*
  2175:   print_endline ("Cal_apply, ret type=" ^ sbt syms.dfns rt);
  2176:   *)
  2177:   r
  2178: 
  2179: and cal_apply' syms sr ((be1,t1) as tbe1) ((be2,t2) as tbe2) : tbexpr_t =
  2180:   let rest =
  2181:     match unfold syms.dfns t1 with
  2182:     | `BTYP_lvalue (`BTYP_function (argt,rest))
  2183:     | `BTYP_function (argt,rest)
  2184:     | `BTYP_lvalue (`BTYP_cfunction (argt,rest))
  2185:     | `BTYP_cfunction (argt,rest) ->
  2186:       if type_match syms.dfns argt t2
  2187:       then rest
  2188:       else
  2189:         clierr sr
  2190:         (
  2191:           "[cal_apply] Function " ^
  2192:           sbe syms.dfns tbe1 ^
  2193:           "\nof type " ^
  2194:           sbt syms.dfns t1 ^
  2195:           "\napplied to argument " ^
  2196:           sbe syms.dfns tbe2 ^
  2197:           "\n of type " ^
  2198:           sbt syms.dfns t2 ^
  2199:           "\nwhich doesn't agree with parameter type\n" ^
  2200:           sbt syms.dfns argt
  2201:         )
  2202: 
  2203:     (* HACKERY TO SUPPORT STRUCT CONSTRUCTORS *)
  2204:     | `BTYP_inst (index,ts) ->
  2205:       begin match get_data syms.dfns index with
  2206:       { id=id;vs=vs;symdef=entry} ->
  2207:         begin match entry with
  2208:         | `SYMDEF_cstruct (cs)
  2209:         | `SYMDEF_struct (cs) -> t1
  2210:         | _ ->
  2211:           clierr sr
  2212:           (
  2213:             "[cal_apply] Attempt to apply non-struct " ^ id ^ ", type " ^
  2214:             sbt syms.dfns t1 ^
  2215:             " as constructor"
  2216:           )
  2217:         end
  2218:       end
  2219:     | _ ->
  2220:       clierr sr
  2221:       (
  2222:         "Attempt to apply non-function\n" ^
  2223:         sbe syms.dfns tbe1 ^
  2224:         "\nof type\n" ^
  2225:         sbt syms.dfns t1 ^
  2226:         "\nto argument of type\n" ^
  2227:         sbe syms.dfns tbe2
  2228:       )
  2229:   in
  2230:   (*
  2231:   print_endline
  2232:   (
  2233:     "---------------------------------------" ^
  2234:     "\nApply type " ^ sbt syms.dfns t1 ^
  2235:     "\nto argument of type " ^ sbt syms.dfns t2 ^
  2236:     "\nresult type is " ^ sbt syms.dfns rest ^
  2237:     "\n-------------------------------------"
  2238:   );
  2239:   *)
  2240: 
  2241:   let rest = varmap_subst syms.varmap rest in
  2242:   if rest = `BTYP_void then
  2243:     clierr sr
  2244:     (
  2245:       "[cal_apply] Function " ^
  2246:       sbe syms.dfns tbe1 ^
  2247:       "\nof type " ^
  2248:       sbt syms.dfns t1 ^
  2249:       "\napplied to argument " ^
  2250:       sbe syms.dfns tbe2 ^
  2251:       "\n of type " ^
  2252:       sbt syms.dfns t2 ^
  2253:       "\nreturns void"
  2254:     )
  2255:   else
  2256: 
  2257:   (* We have to allow type variables now .. the result
  2258:   should ALWAYS be determined, and independent of function
  2259:   return type unknowns, even if that means it is a recursive
  2260:   type, perhaps like 'Fix 0' ..: we should really test
  2261:   for the *function* return type variable not being
  2262:   eliminated ..
  2263:   *)
  2264:   (*
  2265:   if var_occurs rest
  2266:   then
  2267:     clierr sr
  2268:     (
  2269:       "[cal_apply] Type variable in return type applying\n" ^
  2270:         sbe syms.dfns tbe1 ^
  2271:         "\nof type\n" ^
  2272:         sbt syms.dfns t1 ^
  2273:         "\nto argument of type\n" ^
  2274:         sbe syms.dfns tbe2
  2275:     )
  2276:   ;
  2277:   *)
  2278:   (*
  2279:   match be1 with
  2280:   | `BEXPR_closure (i,ts) ->
  2281:     begin match Hashtbl.find syms.dfns i with
  2282:     | {symdef=`SYMDEF_fun _}
  2283:     | {symdef=`SYMDEF_callback _} ->
  2284:       `BEXPR_apply_prim (i,ts, (be2,lower t2)),rest
  2285:     | {symdef=`SYMDEF_function _} ->
  2286:       `BEXPR_apply_direct (i,ts, (be2,lower t2)),rest
  2287:     | _ -> (* needed temporarily for constructors .. *)
  2288:       `BEXPR_apply_direct (i,ts, (be2,lower t2)),rest
  2289: 
  2290:     end
  2291:   | _ ->
  2292:   *)
  2293:     `BEXPR_apply ((be1,lower t1), (be2,lower t2)),rest
  2294: 
  2295: and koenig_lookup syms env rs sra id' name_map fn t2 ts =
  2296:   (*
  2297:   print_endline ("Applying Koenig lookup for " ^ fn);
  2298:   *)
  2299:   let entries =
  2300:     try Hashtbl.find name_map fn
  2301:     with Not_found ->
  2302:       clierr sra
  2303:       (
  2304:         "Koenig lookup: can't find name "^
  2305:         fn^ " in " ^
  2306:         (match id' with
  2307:         | "" -> "top level module"
  2308:         | _ -> "module '" ^ id' ^ "'"
  2309:         )
  2310:       )
  2311:   in
  2312:   match (entries:entry_set_t) with
  2313:   | `FunctionEntry fs ->
  2314:     (*
  2315:     print_endline ("Got candidates: " ^ string_of_entry_set entries);
  2316:     *)
  2317:     begin match resolve_overload' syms env rs sra fs fn [t2] ts with
  2318:     | Some (index'',t,ret,mgu,ts) ->
  2319:       (*
  2320:       print_endline "Overload resolution OK";
  2321:       *)
  2322:       `BEXPR_closure (index'',ts),
  2323:        typeofindex_with_ts syms sra index'' ts
  2324: 
  2325: 
  2326:     | None ->
  2327:         (*
  2328:         let n = ref 0
  2329:         in Hashtbl.iter (fun _ _ -> incr n) name_map;
  2330:         print_endline ("module defines " ^ string_of_int !n^ " entries");
  2331:         *)
  2332:         clierr sra
  2333:         (
  2334:           "[flx_ebind] Koenig lookup: Can't find match for " ^ fn ^
  2335:           "\ncandidates are: " ^ full_string_of_entry_set syms.dfns entries
  2336:         )
  2337:     end
  2338:   | `NonFunctionEntry _ -> clierr sra "Koenig lookup expected function"
  2339: 
  2340: (* this routine has to return a function or procedure .. *)
  2341: and lookup_qn_with_sig
  2342:   syms
  2343:   sra srn
  2344:   env
  2345:   (qn:qualified_name_t)
  2346:   (signs:btypecode_t list)
  2347: =
  2348: try
  2349:   lookup_qn_with_sig'
  2350:     syms
  2351:     sra srn
  2352:     env rsground
  2353:     qn
  2354:     signs
  2355: with
  2356:   | Free_fixpoint b ->
  2357:     clierr sra
  2358:     ("Recursive dependency resolving name " ^ string_of_qualified_name qn)
  2359: 
  2360: and lookup_qn_with_sig'
  2361:   syms
  2362:   sra srn
  2363:   env (rs:recstop)
  2364:   (qn:qualified_name_t)
  2365:   (signs:btypecode_t list)
  2366: : tbexpr_t =
  2367:   (*
  2368:   print_endline ("[lookup_qn_with_sig] " ^ string_of_qualified_name qn);
  2369:   print_endline ("sigs = " ^ catmap "," (sbt syms.dfns) signs);
  2370:   print_endline ("expr_fixlist is " ^
  2371:     catmap ","
  2372:     (fun (e,d) -> string_of_expr e ^ " [depth " ^si d^"]")
  2373:     rs.expr_fixlist
  2374:   );
  2375:   *)
  2376:   let bt sr t =
  2377:     (*
  2378:     print_endline "NON PROPAGATING BIND TYPE";
  2379:     *)
  2380:     bind_type syms env sr t
  2381:   in
  2382:   let handle_nonfunction_index index ts =
  2383:     begin match get_data syms.dfns index with
  2384:     {id=id;sr=sr;parent=parent;vs=vs;privmap=table;dirs=dirs;symdef=entry}
  2385:     ->
  2386:       begin match entry with
  2387:       | `SYMDEF_inherit_fun qn ->
  2388:           clierr sr "Chasing functional inherit in lookup_qn_with_sig'";
  2389: 
  2390:       | `SYMDEF_inherit qn ->
  2391:           clierr sr "Chasing inherit in lookup_qn_with_sig'";
  2392: 
  2393:       | `SYMDEF_regmatch _
  2394:       | `SYMDEF_reglex _
  2395:       | `SYMDEF_cstruct _
  2396:       | `SYMDEF_struct _ ->
  2397:         (*
  2398:         print_endline ("Struct constructor found, type= " ^ sbt syms.dfns t);
  2399:         *)
  2400: (*
  2401: print_endline (id ^ ": lookup_qn_with_sig: struct/regmatch/lex");
  2402: *)
  2403:         (*
  2404:         let ts = adjust_ts syms sr index ts in
  2405:         *)
  2406:         let sign = try hd signs with _ -> assert false in
  2407:         let t = typeofindex_with_ts syms sr index ts in
  2408:         begin match t with
  2409:         | `BTYP_function (a,_) ->
  2410:           if not (type_match syms.dfns a sign) then
  2411:             clierr sr
  2412:             (
  2413:               "[lookup_qn_with_sig] Struct constructor for "^id^" has wrong signature, got:\n" ^
  2414:               sbt syms.dfns t ^
  2415:               "\nexpected:\n" ^
  2416:               sbt syms.dfns sign
  2417:             )
  2418:         | _ -> assert false
  2419:         end
  2420:         ;
  2421:         `BEXPR_closure (index,ts),
  2422:         t
  2423: 
  2424:       | `SYMDEF_union _
  2425:       | `SYMDEF_type_alias _ ->
  2426:         (*
  2427:         print_endline "mapping type name to _ctor_type [2]";
  2428:         *)
  2429:         let qn =  match qn with
  2430:           | `AST_name (sr,name,ts) -> `AST_name (sr,"_ctor_"^name,ts)
  2431:           | `AST_lookup (sr,(e,name,ts)) -> `AST_lookup (sr,(e,"_ctor_"^name,ts))
  2432:           | _ -> failwith "Unexpected name kind .."
  2433:         in
  2434:         lookup_qn_with_sig' syms sra srn env rs qn signs
  2435: 
  2436:       | `SYMDEF_const (t,_,_)
  2437:       | `SYMDEF_val t
  2438:       | `SYMDEF_var t
  2439:       | `SYMDEF_ref t
  2440:       | `SYMDEF_parameter (_,t)
  2441:         ->
  2442: print_endline (id ^ ": lookup_qn_with_sig: val/var");
  2443:         (*
  2444:         let ts = adjust_ts syms sr index ts in
  2445:         *)
  2446:         let t = bt sr t in
  2447:         let bvs = map (fun (s,i,tp) -> s,i) (fst vs) in
  2448:         let t = try tsubst bvs ts t with _ -> failwith "[lookup_qn_with_sig] WOOPS" in
  2449:         begin match t with
  2450:         | `BTYP_function (a,b) ->
  2451:           let sign = try hd signs with _ -> assert false in
  2452:           if not (type_match syms.dfns a sign) then
  2453:           clierr srn
  2454:           (
  2455:             "[lookup_qn_with_sig] Expected variable "^id ^
  2456:             "<" ^ si index ^ "> to have function type with signature " ^
  2457:             sbt syms.dfns sign ^
  2458:             ", got function type:\n" ^
  2459:             sbt syms.dfns t
  2460:           )
  2461:           else
  2462:             `BEXPR_name (index, ts),
  2463:             t
  2464: 
  2465:         | _ ->
  2466:           clierr srn
  2467:           (
  2468:             "[lookup_qn_with_sig] expected variable " ^
  2469:             id ^ "<" ^ si index ^ "> to be of function type, got:\n" ^
  2470:             sbt syms.dfns t
  2471: 
  2472:           )
  2473:         end
  2474:       | _ ->
  2475:         clierr sr
  2476:         (
  2477:           "[lookup_qn_with_sig] Named Non function entry "^id^
  2478:           " must be function type: requires struct," ^
  2479:           "or value or variable of function type"
  2480:         )
  2481:       end
  2482:     end
  2483:   in
  2484:   match qn with
  2485:   | `AST_callback (sr,qn) ->
  2486:     failwith "[lookup_qn_with_sig] Callbacks not implemented yet"
  2487: 
  2488:   | `AST_the (sr,qn) ->
  2489:     (*
  2490:     print_endline ("AST_the " ^ string_of_qualified_name qn);
  2491:     *)
  2492:     lookup_qn_with_sig' syms sra srn
  2493:     env rs
  2494:     qn signs
  2495: 
  2496:   | `AST_void _ -> clierr sra "qualified-name is void"
  2497: 
  2498:   | `AST_case_tag _ -> clierr sra "Can't lookup case tag here"
  2499: 
  2500:   (* WEIRD .. this is a qualified name syntactically ..
  2501:     but semantically it belongs in bind_expression
  2502:     where this code is duplicated ..
  2503: 
  2504:     AH NO it isn't. Here, we always return a function
  2505:     type, even for constant constructors (because we
  2506:     have a signature ..)
  2507:   *)
  2508:   | `AST_typed_case (sr,v,t) ->
  2509:     let t = bt sr t in
  2510:     begin match unfold syms.dfns t with
  2511:     | `BTYP_unitsum k ->
  2512:       if v<0 or v>= k
  2513:       then clierr sra "Case index out of range of sum"
  2514:       else
  2515:         let ct = `BTYP_function (unit_t,t) in
  2516:         `BEXPR_case (v,t),ct
  2517: 
  2518:     | `BTYP_sum ls ->
  2519:       if v<0 or v >= length ls
  2520:       then clierr sra "Case index out of range of sum"
  2521:       else let vt = nth ls v in
  2522:       let ct = `BTYP_function (vt,t) in
  2523:       `BEXPR_case (v,t), ct
  2524: 
  2525:     | _ ->
  2526:       clierr sr
  2527:       (
  2528:         "[lookup_qn_with_sig] Type of case must be sum, got " ^
  2529:         sbt syms.dfns t
  2530:       )
  2531:     end
  2532: 
  2533:   | `AST_name (sr,name,ts) ->
  2534:     (* HACKERY TO SUPPORT _ctor_type lookup -- this is really gross,
  2535:        since the error could be anything ..  the retry here should
  2536:        only be used if the lookup failed because sig_of_symdef found
  2537:        a typename..
  2538:     *)
  2539:     let ts = map (bt sr) ts in
  2540:     begin try
  2541:       lookup_name_with_sig
  2542:         syms
  2543:         sra srn
  2544:         env env rs name ts signs
  2545:     with OverloadKindError (sr,s) ->
  2546:     try
  2547:       lookup_name_with_sig
  2548:         syms
  2549:         sra srn
  2550:         env env rs ("_ctor_" ^ name) ts signs
  2551:      with ClientError (_,s2) ->
  2552:        clierr sr
  2553:        (
  2554:        "ERROR: " ^ s ^
  2555:        "\nERROR2: " ^ s2
  2556:        )
  2557:     end
  2558: 
  2559:   | `AST_index (sr,name,index) as x ->
  2560:     (*
  2561:     print_endline ("[lookup qn with sig] AST_index " ^ string_of_qualified_name x);
  2562:     *)
  2563:     begin match get_data syms.dfns index with
  2564:     | {vs=vs; id=id; sr=sra; symdef=entry} ->
  2565:     match entry with
  2566:     | `SYMDEF_fun _
  2567:     | `SYMDEF_function _
  2568:     | `SYMDEF_match_check _
  2569:       ->
  2570:       let vs = find_vs syms index in
  2571:       let ts = map (fun (_,i,_) -> `BTYP_var (i,`BTYP_type 0)) (fst vs) in
  2572:       `BEXPR_closure (index,ts),
  2573:       inner_typeofindex syms rs index
  2574: 
  2575:     | _ ->
  2576:       (*
  2577:       print_endline "Non function ..";
  2578:       *)
  2579:       let ts = map (fun (_,i,_) -> `BTYP_var (i,`BTYP_type 0)) (fst vs) in
  2580:       handle_nonfunction_index index ts
  2581:     end
  2582: 
  2583:   | `AST_lookup (sr,(qn',name,ts)) ->
  2584:     let m =  eval_module_expr syms env qn' in
  2585:     match m with (Simple_module (impl, ts',htab,dirs)) ->
  2586:     (* let n = length ts in *)
  2587:     let ts = map (bt sr)( ts' @ ts) in
  2588:     (*
  2589:     print_endline ("Module " ^ si impl ^ "[" ^ catmap "," (sbt syms.dfns) ts' ^"]");
  2590:     *)
  2591:     let env' = mk_bare_env syms impl in
  2592:     let tables = get_pub_tables syms env' rs dirs in
  2593:     let result = lookup_name_in_table_dirs htab tables sr name in
  2594:     begin match result with
  2595:     | None ->
  2596:       clierr sr
  2597:       (
  2598:         "[lookup_qn_with_sig] AST_lookup: Simple_module: Can't find name " ^ name
  2599:       )
  2600:     | Some entries -> match entries with
  2601:     | `NonFunctionEntry (index) ->
  2602:       handle_nonfunction_index (sye index) ts
  2603: 
  2604:     | `FunctionEntry fs ->
  2605:       match
  2606:         resolve_overload'
  2607:         syms env rs sra fs name signs ts
  2608:       with
  2609:       | Some (index,t,ret,mgu,ts) ->
  2610:         (*
  2611:         print_endline ("Resolved overload for " ^ name);
  2612:         print_endline ("ts = [" ^ catmap ", " (sbt syms.dfns) ts ^ "]");
  2613:         *)
  2614:         (*
  2615:         let ts = adjust_ts syms sr index ts in
  2616:         *)
  2617:         `BEXPR_closure (index,ts),
  2618:          typeofindex_with_ts syms sr index ts
  2619: 
  2620:       | None ->
  2621:         clierr sra
  2622:         (
  2623:           "[lookup_qn_with_sig] (Simple module) Unable to resolve overload of " ^
  2624:           string_of_qualified_name qn ^
  2625:           " of (" ^ catmap "," (sbt syms.dfns) signs ^")\n" ^
  2626:           "candidates are: " ^ full_string_of_entry_set syms.dfns entries
  2627:         )
  2628:     end
  2629: 
  2630: and lookup_type_qn_with_sig'
  2631:   syms
  2632:   sra srn
  2633:   env (rs:recstop)
  2634:   (qn:qualified_name_t)
  2635:   (signs:btypecode_t list)
  2636: : btypecode_t =
  2637:   (*
  2638:   print_endline ("[lookup_type_qn_with_sig] " ^ string_of_qualified_name qn);
  2639:   print_endline ("sigs = " ^ catmap "," (sbt syms.dfns) signs);
  2640:   print_endline ("expr_fixlist is " ^
  2641:     catmap ","
  2642:     (fun (e,d) -> string_of_expr e ^ " [depth " ^si d^"]")
  2643:     rs.expr_fixlist
  2644:   );
  2645:   *)
  2646:   let bt sr t =
  2647:     (*
  2648:     print_endline "NON PROPAGATING BIND TYPE";
  2649:     *)
  2650:     bind_type syms env sr t
  2651:   in
  2652:   let handle_nonfunction_index index ts =
  2653:     print_endline ("Found non function? index " ^ si index);
  2654:     begin match get_data syms.dfns index with
  2655:     {id=id;sr=sr;parent=parent;vs=vs;privmap=table;dirs=dirs;symdef=entry}
  2656:     ->
  2657:       begin match entry with
  2658:       | `SYMDEF_inherit_fun qn ->
  2659:           clierr sr "Chasing functional inherit in lookup_qn_with_sig'";
  2660: 
  2661:       | `SYMDEF_inherit qn ->
  2662:           clierr sr "Chasing inherit in lookup_qn_with_sig'";
  2663: 
  2664:       | `SYMDEF_regmatch _ ->
  2665:           clierr sr "[lookup_type_qn_with_sig] Found regmatch"
  2666: 
  2667:       | `SYMDEF_reglex _ ->
  2668:           clierr sr "[lookup_type_qn_with_sig] Found reglex"
  2669: 
  2670:       | `SYMDEF_cstruct _
  2671:       | `SYMDEF_struct _ ->
  2672:         (*
  2673:         print_endline ("[lookup_type_qn_with_sig] Struct constructor found, type= " ^ sbt syms.dfns t);
  2674:         *)
  2675:         let sign = try hd signs with _ -> assert false in
  2676:         let t = typeofindex_with_ts syms sr index ts in
  2677:         begin match t with
  2678:         | `BTYP_function (a,_) ->
  2679:           if not (type_match syms.dfns a sign) then
  2680:             clierr sr
  2681:             (
  2682:               "[lookup_qn_with_sig] Struct constructor for "^id^" has wrong signature, got:\n" ^
  2683:               sbt syms.dfns t ^
  2684:               "\nexpected:\n" ^
  2685:               sbt syms.dfns sign
  2686:             )
  2687:         | _ -> assert false
  2688:         end
  2689:         ;
  2690:         t
  2691: 
  2692:       | `SYMDEF_union _
  2693:       | `SYMDEF_type_alias _ ->
  2694:         print_endline "mapping type name to _ctor_type [2]";
  2695:         let qn =  match qn with
  2696:           | `AST_name (sr,name,ts) -> `AST_name (sr,"_ctor_"^name,ts)
  2697:           | `AST_lookup (sr,(e,name,ts)) -> `AST_lookup (sr,(e,"_ctor_"^name,ts))
  2698:           | _ -> failwith "Unexpected name kind .."
  2699:         in
  2700:         lookup_type_qn_with_sig' syms sra srn env rs qn signs
  2701: 
  2702:       | `SYMDEF_const (t,_,_)
  2703:       | `SYMDEF_val t
  2704:       | `SYMDEF_var t
  2705:       | `SYMDEF_ref t
  2706:       | `SYMDEF_parameter (_,t)
  2707:         ->
  2708:         clierr sr (id ^ ": lookup_type_qn_with_sig: val/var/const/ref/param: not type");
  2709: 
  2710:       | _ ->
  2711:         clierr sr
  2712:         (
  2713:           "[lookup_type_qn_with_sig] Named Non function entry "^id^
  2714:           " must be type function"
  2715:         )
  2716:       end
  2717:     end
  2718:   in
  2719:   match qn with
  2720:   | `AST_callback (sr,qn) ->
  2721:     failwith "[lookup_qn_with_sig] Callbacks not implemented yet"
  2722: 
  2723:   | `AST_the (sr,qn) ->
  2724:     print_endline ("AST_the " ^ string_of_qualified_name qn);
  2725:     lookup_type_qn_with_sig' syms sra srn
  2726:     env rs
  2727:     qn signs
  2728: 
  2729:   | `AST_void _ -> clierr sra "qualified-name is void"
  2730: 
  2731:   | `AST_case_tag _ -> clierr sra "Can't lookup case tag here"
  2732: 
  2733:   | `AST_typed_case (sr,v,t) ->
  2734:     let t = bt sr t in
  2735:     begin match unfold syms.dfns t with
  2736:     | `BTYP_unitsum k ->
  2737:       if v<0 or v>= k
  2738:       then clierr sra "Case index out of range of sum"
  2739:       else
  2740:         let ct = `BTYP_function (unit_t,t) in
  2741:         ct
  2742: 
  2743:     | `BTYP_sum ls ->
  2744:       if v<0 or v >= length ls
  2745:       then clierr sra "Case index out of range of sum"
  2746:       else let vt = nth ls v in
  2747:       let ct = `BTYP_function (vt,t) in
  2748:       ct
  2749: 
  2750:     | _ ->
  2751:       clierr sr
  2752:       (
  2753:         "[lookup_qn_with_sig] Type of case must be sum, got " ^
  2754:         sbt syms.dfns t
  2755:       )
  2756:     end
  2757: 
  2758:   | `AST_name (sr,name,ts) ->
  2759:     (*
  2760:     print_endline ("AST_name " ^ name);
  2761:     *)
  2762:     let ts = map (bt sr) ts in
  2763:     lookup_type_name_with_sig
  2764:         syms
  2765:         sra srn
  2766:         env env rs name ts signs
  2767: 
  2768:   | `AST_index (sr,name,index) as x ->
  2769:     (*
  2770:     print_endline ("[lookup qn with sig] AST_index " ^ string_of_qualified_name x);
  2771:     *)
  2772:     begin match get_data syms.dfns index with
  2773:     | {vs=vs; id=id; sr=sra; symdef=entry} ->
  2774:     match entry with
  2775:     | `SYMDEF_fun _
  2776:     | `SYMDEF_function _
  2777:     | `SYMDEF_match_check _
  2778:       ->
  2779:       let vs = find_vs syms index in
  2780:       let ts = map (fun (_,i,_) -> `BTYP_var (i,`BTYP_type 0)) (fst vs) in
  2781:       inner_typeofindex syms rs index
  2782: 
  2783:     | _ ->
  2784:       (*
  2785:       print_endline "Non function ..";
  2786:       *)
  2787:       let ts = map (fun (_,i,_) -> `BTYP_var (i,`BTYP_type 0)) (fst vs) in
  2788:       handle_nonfunction_index index ts
  2789:     end
  2790: 
  2791:   | `AST_lookup (sr,(qn',name,ts)) ->
  2792:     let m =  eval_module_expr syms env qn' in
  2793:     match m with (Simple_module (impl, ts',htab,dirs)) ->
  2794:     (* let n = length ts in *)
  2795:     let ts = map (bt sr)( ts' @ ts) in
  2796:     (*
  2797:     print_endline ("Module " ^ si impl ^ "[" ^ catmap "," (sbt syms.dfns) ts' ^"]");
  2798:     *)
  2799:     let env' = mk_bare_env syms impl in
  2800:     let tables = get_pub_tables syms env' rs dirs in
  2801:     let result = lookup_name_in_table_dirs htab tables sr name in
  2802:     begin match result with
  2803:     | None ->
  2804:       clierr sr
  2805:       (
  2806:         "[lookup_qn_with_sig] AST_lookup: Simple_module: Can't find name " ^ name
  2807:       )
  2808:     | Some entries -> match entries with
  2809:     | `NonFunctionEntry (index) ->
  2810:       handle_nonfunction_index (sye index) ts
  2811: 
  2812:     | `FunctionEntry fs ->
  2813:       match
  2814:         resolve_overload'
  2815:         syms env rs sra fs name signs ts
  2816:       with
  2817:       | Some (index,t,ret,mgu,ts) ->
  2818:         print_endline ("Resolved overload for " ^ name);
  2819:         print_endline ("ts = [" ^ catmap ", " (sbt syms.dfns) ts ^ "]");
  2820:         (*
  2821:         let ts = adjust_ts syms sr index ts in
  2822:         *)
  2823:         let t =  typeofindex_with_ts syms sr index ts in
  2824:         print_endline "WRONG!";
  2825:         t
  2826: 
  2827:       | None ->
  2828:         clierr sra
  2829:         (
  2830:           "[lookup_type_qn_with_sig] (Simple module) Unable to resolve overload of " ^
  2831:           string_of_qualified_name qn ^
  2832:           " of (" ^ catmap "," (sbt syms.dfns) signs ^")\n" ^
  2833:           "candidates are: " ^ full_string_of_entry_set syms.dfns entries
  2834:         )
  2835:     end
  2836: 
  2837: and lookup_name_with_sig
  2838:   syms
  2839:   sra srn
  2840:   caller_env env
  2841:   (rs:recstop)
  2842:   (name : string)
  2843:   (ts : btypecode_t list)
  2844:   (t2:btypecode_t list)
  2845: : tbexpr_t =
  2846:   (*
  2847:   print_endline ("[lookup_name_with_sig] " ^ name ^
  2848:     " of " ^ catmap "," (sbt syms.dfns) t2)
  2849:   ;
  2850:   *)
  2851:   match env with
  2852:   | [] ->
  2853:     clierr srn
  2854:     (
  2855:       "[lookup_name_with_sig] Can't find " ^ name ^
  2856:       " of " ^ catmap "," (sbt syms.dfns) t2
  2857:     )
  2858:   | (_,_,table,dirs)::tail ->
  2859:     match
  2860:       lookup_name_in_table_dirs_with_sig
  2861:       (table, dirs)
  2862:       syms caller_env env rs
  2863:       sra srn name ts t2
  2864:     with
  2865:     | Some result -> (result:>tbexpr_t)
  2866:     | None ->
  2867:       let tbx=
  2868:         lookup_name_with_sig
  2869:           syms
  2870:           sra srn
  2871:           caller_env tail rs name ts t2
  2872:        in (tbx:>tbexpr_t)
  2873: 
  2874: and lookup_type_name_with_sig
  2875:   syms
  2876:   sra srn
  2877:   caller_env env
  2878:   (rs:recstop)
  2879:   (name : string)
  2880:   (ts : btypecode_t list)
  2881:   (t2:btypecode_t list)
  2882: : btypecode_t =
  2883:   (*
  2884:   print_endline ("[lookup_type_name_with_sig] " ^ name ^
  2885:     " of " ^ catmap "," (sbt syms.dfns) t2)
  2886:   ;
  2887:   *)
  2888:   match env with
  2889:   | [] ->
  2890:     clierr srn
  2891:     (
  2892:       "[lookup_name_with_sig] Can't find " ^ name ^
  2893:       " of " ^ catmap "," (sbt syms.dfns) t2
  2894:     )
  2895:   | (_,_,table,dirs)::tail ->
  2896:     match
  2897:       lookup_type_name_in_table_dirs_with_sig
  2898:       (table, dirs)
  2899:       syms caller_env env rs
  2900:       sra srn name ts t2
  2901:     with
  2902:     | Some result -> result
  2903:     | None ->
  2904:       let tbx=
  2905:         lookup_type_name_with_sig
  2906:           syms
  2907:           sra srn
  2908:           caller_env tail rs name ts t2
  2909:        in tbx
  2910: 
  2911: and handle_type
  2912:   syms
  2913:   (rs:recstop)
  2914:   sra srn
  2915:   name
  2916:   ts
  2917:   (index : int)
  2918: : btypecode_t
  2919: =
  2920: 
  2921:   let mkenv i = build_env syms (Some i) in
  2922:   let bt sr t =
  2923:     bind_type' syms (mkenv index) rs sr t [] mkenv
  2924:   in
  2925: 
  2926:   match get_data syms.dfns index with
  2927:   {
  2928:     id=id;sr=sr;vs=vs;parent=parent;
  2929:     privmap=tabl;dirs=dirs;
  2930:     symdef=entry
  2931:   }
  2932:   ->
  2933:   match entry with
  2934:   | `SYMDEF_match_check _
  2935:   | `SYMDEF_function _
  2936:   | `SYMDEF_fun _
  2937:   | `SYMDEF_struct _
  2938:   | `SYMDEF_cstruct _
  2939:   | `SYMDEF_nonconst_ctor _
  2940:   | `SYMDEF_regmatch _
  2941:   | `SYMDEF_reglex _
  2942:   | `SYMDEF_callback _
  2943:     ->
  2944:     print_endline ("Handle function " ^id^"<"^si index^">, ts=" ^ catmap "," (sbt syms.dfns) ts);
  2945:     `BTYP_inst (index,ts)
  2946:     (*
  2947:     let t = inner_typeofindex_with_ts syms sr rs index ts
  2948:     in
  2949:     (
  2950:       match t with
  2951:       | `BTYP_cfunction (s,d) as t -> t
  2952:       | `BTYP_function (s,d) as t -> t
  2953:       | t ->
  2954:         ignore begin
  2955:           match t with
  2956:           | `BTYP_fix _ -> raise (Free_fixpoint t)
  2957:           | _ -> try unfold syms.dfns t with
  2958:           | _ -> raise (Free_fixpoint t)
  2959:         end
  2960:         ;
  2961:         clierr sra
  2962:         (
  2963:           "[handle_function]: closure operator expected '"^name^"' to have function type, got '"^
  2964:           sbt syms.dfns t ^ "'"
  2965:         )
  2966:     )
  2967:     *)
  2968: 
  2969:   | `SYMDEF_type_alias _ ->
  2970:     bind_type_index syms (rs:recstop) sr index ts mkenv
  2971: 
  2972:   | _ ->
  2973:     clierr sra
  2974:     (
  2975:       "[handle_type] Expected "^name^" to be function, got: " ^
  2976:       string_of_symdef entry name vs
  2977:     )
  2978: 
  2979: and handle_function
  2980:   syms
  2981:   (rs:recstop)
  2982:   sra srn
  2983:   name
  2984:   ts
  2985:   (index : int)
  2986: : tbexpr_t
  2987: =
  2988:   match get_data syms.dfns index with
  2989:   {
  2990:     id=id;sr=sr;vs=vs;parent=parent;
  2991:     privmap=tabl;dirs=dirs;
  2992:     symdef=entry
  2993:   }
  2994:   ->
  2995:   match entry with
  2996:   | `SYMDEF_match_check _
  2997:   | `SYMDEF_function _
  2998:   | `SYMDEF_fun _
  2999:   | `SYMDEF_struct _
  3000:   | `SYMDEF_cstruct _
  3001:   | `SYMDEF_nonconst_ctor _
  3002:   | `SYMDEF_regmatch _
  3003:   | `SYMDEF_reglex _
  3004:   | `SYMDEF_callback _
  3005:     ->
  3006:     (*
  3007:     print_endline ("Handle function " ^id^"<"^si index^">, ts=" ^ catmap "," (sbt syms.dfns) ts);
  3008:     *)
  3009:     let t = inner_typeofindex_with_ts syms sr rs index ts
  3010:     in
  3011:     `BEXPR_closure (index,ts),
  3012:     (
  3013:       match t with
  3014:       | `BTYP_cfunction (s,d) as t -> t
  3015:       | `BTYP_function (s,d) as t -> t
  3016:       | t ->
  3017:         ignore begin
  3018:           match t with
  3019:           | `BTYP_fix _ -> raise (Free_fixpoint t)
  3020:           | _ -> try unfold syms.dfns t with
  3021:           | _ -> raise (Free_fixpoint t)
  3022:         end
  3023:         ;
  3024:         clierr sra
  3025:         (
  3026:           "[handle_function]: closure operator expected '"^name^"' to have function type, got '"^
  3027:           sbt syms.dfns t ^ "'"
  3028:         )
  3029:     )
  3030:   | `SYMDEF_type_alias (`TYP_case _)  (* -> failwith "Finally found case??" *)
  3031:   | `SYMDEF_type_alias (`TYP_typefun _) ->
  3032:     (* THIS IS A HACK .. WE KNOW THE TYPE IS NOT NEEDED BY THE CALLER .. *)
  3033:     (* let t = inner_typeofindex_with_ts syms sr rs index ts in *)
  3034:     let t = `BTYP_function (`BTYP_type 0,`BTYP_type 0) in
  3035:     `BEXPR_closure (index,ts),
  3036:     (
  3037:       match t with
  3038:       | `BTYP_function (s,d) as t -> t
  3039:       | t ->
  3040:         ignore begin
  3041:           match t with
  3042:           | `BTYP_fix _ -> raise (Free_fixpoint t)
  3043:           | _ -> try unfold syms.dfns t with
  3044:           | _ -> raise (Free_fixpoint t)
  3045:         end
  3046:         ;
  3047:         clierr sra
  3048:         (
  3049:           "[handle_function]: closure operator expected '"^name^"' to have function type, got '"^
  3050:           sbt syms.dfns t ^ "'"
  3051:         )
  3052:     )
  3053: 
  3054:   | _ ->
  3055:     clierr sra
  3056:     (
  3057:       "[handle_function] Expected "^name^" to be function, got: " ^
  3058:       string_of_symdef entry name vs
  3059:     )
  3060: 
  3061: and handle_variable syms
  3062:   env (rs:recstop)
  3063:   index id sr ts t t2
  3064: =
  3065:   (* HACKED the params argument to [] .. this is WRONG!! *)
  3066:   let mkenv i = build_env syms (Some i) in
  3067:   let bt sr t =
  3068:     bind_type' syms env rs sr t [] mkenv
  3069:   in
  3070: 
  3071:     (* we have to check the variable is the right type *)
  3072:     let t = bt sr t in
  3073:     let ts = adjust_ts syms sr index ts in
  3074:     let vs = find_vs syms index in
  3075:     let bvs = map (fun (s,i,tp) -> s,i) (fst vs) in
  3076:     let t = beta_reduce syms sr (tsubst bvs ts t) in
  3077:     let t = match t with | `BTYP_lvalue t -> t | t -> t in
  3078:     begin match t with
  3079:     | `BTYP_cfunction (d,c)
  3080:     | `BTYP_function (d,c) ->
  3081:       if not (type_match syms.dfns d t2) then
  3082:       clierr sr
  3083:       (
  3084:         "[handle_variable(1)] Expected variable "^id ^
  3085:         "<" ^ si index ^ "> to have function type with signature " ^
  3086:         sbt syms.dfns t2 ^
  3087:         ", got function type:\n" ^
  3088:         sbt syms.dfns t
  3089:       )
  3090:       else
  3091:         (*
  3092:         let ts = adjust_ts syms sr index ts in
  3093:         *)
  3094:         Some
  3095:         (
  3096:           `BEXPR_name (index, ts),t
  3097:           (* should equal t ..
  3098:           typeofindex_with_ts syms sr index ts
  3099:           *)
  3100:         )
  3101: 
  3102:     (* anything other than function type, dont check the sig,
  3103:        just return it..
  3104:     *)
  3105:     | _ ->  Some (`BEXPR_name (index,ts),t)
  3106:     end
  3107: 
  3108: and lookup_name_in_table_dirs_with_sig (table, dirs)
  3109:   syms
  3110:   caller_env env (rs:recstop)
  3111:   sra srn name (ts:btypecode_t list) (t2: btypecode_t list)
  3112: : tbexpr_t option
  3113: =
  3114:   (*
  3115:   print_endline
  3116:   (
  3117:     "LOOKUP NAME "^name ^"["^
  3118:     catmap "," (sbt syms.dfns) ts ^
  3119:     "] IN TABLE DIRS WITH SIG " ^ catmap "," (sbt syms.dfns) t2
  3120:   );
  3121:   *)
  3122:   let result:entry_set_t =
  3123:     match lookup_name_in_htab table name  with
  3124:     | Some x -> x
  3125:     | None -> `FunctionEntry []
  3126:   in
  3127:   match result with
  3128:   | `NonFunctionEntry (index) ->
  3129:     begin match get_data syms.dfns (sye index) with
  3130:     {id=id;sr=sr;parent=parent;vs=vs;pubmap=pubmap;symdef=entry}->
  3131:     (*
  3132:     print_endline ("FOUND " ^ id);
  3133:     *)
  3134:     begin match entry with
  3135:     | `SYMDEF_inherit _ ->
  3136:       clierr sra "Woops found inherit in lookup_name_in_table_dirs_with_sig"
  3137:     | `SYMDEF_inherit_fun _ ->
  3138:       clierr sra "Woops found inherit function in lookup_name_in_table_dirs_with_sig"
  3139: 
  3140:     | `SYMDEF_regmatch _
  3141:     | `SYMDEF_reglex _
  3142:     | `SYMDEF_cstruct _
  3143:     | `SYMDEF_struct _
  3144:     | `SYMDEF_nonconst_ctor _
  3145:       ->
  3146:         (*
  3147:         print_endline "lookup_name_in_table_dirs_with_sig finds struct constructor";
  3148:         *)
  3149:         let ro =
  3150:           resolve_overload'
  3151:           syms caller_env rs sra [index] name t2 ts
  3152:         in
  3153:           begin match ro with
  3154:           | Some (index,t,ret,mgu,ts) ->
  3155:             (*
  3156:             print_endline "handle_function (1)";
  3157:             *)
  3158:             let tb : tbexpr_t =
  3159:               handle_function
  3160:               syms
  3161:               rs
  3162:               sra srn name ts index
  3163:             in
  3164:               Some tb
  3165:           | None -> None
  3166:           end
  3167: 
  3168:     | `SYMDEF_class ->
  3169:       (*
  3170:       print_endline ("Found a class "^name^", look for constructor with hacked name _ctor_"^name);
  3171:       *)
  3172:       let entries = lookup_name_in_htab pubmap ("_ctor_" ^ name) in
  3173:       begin match entries with
  3174:       | None -> clierr sr "Unable to find any constructors for this class"
  3175:       | Some (`NonFunctionEntry _) -> syserr sr
  3176:         "[lookup_name_in_table_dirs_with_sig] Expected constructor to be a procedure"
  3177: 
  3178:       | Some (`FunctionEntry fs) ->
  3179:         (*
  3180:         print_endline ("Ok, found "^si (length fs) ^"constructors for " ^ name);
  3181:         *)
  3182:         let ro =
  3183:           resolve_overload'
  3184:           syms caller_env rs sra fs ("_ctor_" ^ name) t2 ts
  3185:         in
  3186:         match ro with
  3187:           | Some (index,t,ret,mgu,ts) ->
  3188:             print_endline "handle_function (2)";
  3189:             let ((_,tt) as tb) =
  3190:               handle_function
  3191:               syms
  3192:               rs
  3193:               sra srn name ts index
  3194:             in
  3195:               (*
  3196:               print_endline ("SUCCESS: overload chooses " ^ full_string_of_entry_kind syms.dfns index);
  3197:               print_endline ("Value of ts is " ^ catmap "," (sbt syms.dfns) ts);
  3198:               print_endline ("Instantiated closure value is " ^ sbe syms.dfns tb);
  3199:               print_endline ("type is " ^ sbt syms.dfns tt);
  3200:               *)
  3201:               Some tb
  3202:           | None ->
  3203:             clierr sr "Unable to find matching constructor"
  3204:       end
  3205:       (*
  3206:       lookup_name_in_table_dirs_with_sig (table, dirs)
  3207:       syms env rs sra srn ("_ctor_" ^ name) ts t2
  3208:       *)
  3209: 
  3210:     | `SYMDEF_abs _
  3211:     | `SYMDEF_cclass _
  3212:     | `SYMDEF_union _
  3213:     | `SYMDEF_type_alias _ ->
  3214: 
  3215:       (* recursively lookup using "_ctor_" ^ name :
  3216:          WARNING: we might find a constructor with the
  3217:          right name for a different cclass than this one,
  3218:          it isn't clear this is wrong though.
  3219:       *)
  3220:       (*
  3221:       print_endline "mapping type name to _ctor_type";
  3222:       *)
  3223:       lookup_name_in_table_dirs_with_sig (table, dirs)
  3224:       syms caller_env env rs sra srn ("_ctor_" ^ name) ts t2
  3225: 
  3226:     | `SYMDEF_const_ctor (_,t,_,_)
  3227:     | `SYMDEF_const (t,_,_)
  3228:     | `SYMDEF_var t
  3229:     | `SYMDEF_ref t
  3230:     | `SYMDEF_val t
  3231:     | `SYMDEF_parameter (_,t)
  3232:       ->
  3233:       let sign = try hd t2 with _ -> assert false in
  3234:       handle_variable syms env rs (sye index) id srn ts t sign
  3235:     | _
  3236:       ->
  3237:         clierr sra
  3238:         (
  3239:           "[lookup_name_in_table_dirs_with_sig] Expected " ^id^
  3240:           " to be struct or variable of function type, got " ^
  3241:           string_of_symdef entry id vs
  3242:         )
  3243:     end
  3244:     end
  3245: 
  3246:   | `FunctionEntry fs ->
  3247:     (*
  3248:     print_endline ("Found function set size " ^ si (length fs));
  3249:     *)
  3250:     let ro =
  3251:       resolve_overload'
  3252:       syms caller_env rs sra fs name t2 ts
  3253:     in
  3254:     match ro with
  3255:       | Some (index,t,ret,mgu,ts) ->
  3256:         (*
  3257:         print_endline ("handle_function (3) ts=" ^ catmap "," (sbt syms.dfns) ts);
  3258:         let ts = adjust_ts syms sra index ts in
  3259:         print_endline "Adjusted ts";
  3260:         *)
  3261:         let ((_,tt) as tb) =
  3262:           handle_function
  3263:           syms
  3264:           rs
  3265:           sra srn name ts index
  3266:         in
  3267:           (*
  3268:           print_endline ("SUCCESS: overload chooses " ^ full_string_of_entry_kind syms.dfns (mkentry syms dfltvs index));
  3269:           print_endline ("Value of ts is " ^ catmap "," (sbt syms.dfns) ts);
  3270:           print_endline ("Instantiated closure value is " ^ sbe syms.dfns tb);
  3271:           print_endline ("type is " ^ sbt syms.dfns tt);
  3272:           *)
  3273:           Some tb
  3274: 
  3275:       | None ->
  3276:         (*
  3277:         print_endline "Can't overload: Trying opens";
  3278:         *)
  3279:         let opens : entry_set_t list =
  3280:           uniq_cat []
  3281:           (
  3282:             concat
  3283:             (
  3284:               map
  3285:               (fun table ->
  3286:                 match lookup_name_in_htab table name with
  3287:                 | Some x -> [x]
  3288:                 | None -> []
  3289:               )
  3290:               dirs
  3291:             )
  3292:           )
  3293:         in
  3294:         (*
  3295:         print_endline (si (length opens) ^ " OPENS BUILT for " ^ name);
  3296:         *)
  3297:         match opens with
  3298:         | [`NonFunctionEntry i] when
  3299:           (
  3300:               match get_data syms.dfns (sye i) with
  3301:               {id=id;sr=sr;parent=parent;vs=vs;pubmap=pubmap;symdef=entry}->
  3302:               (*
  3303:               print_endline ("FOUND " ^ id);
  3304:               *)
  3305:               match entry with
  3306:               | `SYMDEF_abs _
  3307:               | `SYMDEF_cclass _
  3308:               | `SYMDEF_union _ -> true
  3309:               | _ -> false
  3310:            ) ->
  3311:              (*
  3312:              print_endline "mapping type name to _ctor_type2";
  3313:              *)
  3314:              lookup_name_in_table_dirs_with_sig (table, dirs)
  3315:              syms caller_env env rs sra srn ("_ctor_" ^ name) ts t2
  3316:         | _ ->
  3317:         let fs =
  3318:           match opens with
  3319:           | [`NonFunctionEntry i] -> [i]
  3320:           | [`FunctionEntry ii] -> ii
  3321:           | _ ->
  3322:             merge_functions opens name
  3323:         in
  3324:           let ro =
  3325:             resolve_overload'
  3326:             syms caller_env rs sra fs name t2 ts
  3327:           in
  3328:           (*
  3329:           print_endline "OVERLOAD RESOLVED .. ";
  3330:           *)
  3331:           match ro with
  3332:           | Some (result,t,ret,mgu,ts) ->
  3333:             (*
  3334:             print_endline "handle_function (4)";
  3335:             *)
  3336:             let tb : tbexpr_t =
  3337:               handle_function
  3338:               syms
  3339:               rs
  3340:               sra srn name ts result
  3341:             in
  3342:               Some tb
  3343:           | None ->
  3344:             (*
  3345:             print_endline "FAILURE"; flush stdout;
  3346:             *)
  3347:             None
  3348: 
  3349: and lookup_type_name_in_table_dirs_with_sig (table, dirs)
  3350:   syms
  3351:   caller_env env (rs:recstop)
  3352:   sra srn name (ts:btypecode_t list) (t2: btypecode_t list)
  3353: : btypecode_t option
  3354: =
  3355:   (*
  3356:   print_endline
  3357:   (
  3358:     "LOOKUP TYPE NAME "^name ^"["^
  3359:     catmap "," (sbt syms.dfns) ts ^
  3360:     "] IN TABLE DIRS WITH SIG " ^ catmap "," (sbt syms.dfns) t2
  3361:   );
  3362:   *)
  3363:   let mkenv i = build_env syms (Some i) in
  3364:   let bt sr t =
  3365:     bind_type' syms env rs sr t [] mkenv
  3366:   in
  3367: 
  3368:   let result:entry_set_t =
  3369:     match lookup_name_in_htab table name  with
  3370:     | Some x -> x
  3371:     | None -> `FunctionEntry []
  3372:   in
  3373:   match result with
  3374:   | `NonFunctionEntry (index) ->
  3375:     begin match get_data syms.dfns (sye index) with
  3376:     {id=id;sr=sr;parent=parent;vs=vs;pubmap=pubmap;symdef=entry}->
  3377:     (*
  3378:     print_endline ("FOUND " ^ id);
  3379:     *)
  3380:     begin match entry with
  3381:     | `SYMDEF_inherit _ ->
  3382:       clierr sra "Woops found inherit in lookup_type_name_in_table_dirs_with_sig"
  3383:     | `SYMDEF_inherit_fun _ ->
  3384:       clierr sra "Woops found inherit function in lookup_type_name_in_table_dirs_with_sig"
  3385: 
  3386:     | `SYMDEF_cstruct _
  3387:     | `SYMDEF_struct _
  3388:     | `SYMDEF_nonconst_ctor _
  3389:       ->
  3390:         (*
  3391:         print_endline "lookup_name_in_table_dirs_with_sig finds struct constructor";
  3392:         *)
  3393:         let ro =
  3394:           resolve_overload'
  3395:           syms caller_env rs sra [index] name t2 ts
  3396:         in
  3397:           begin match ro with
  3398:           | Some (index,t,ret,mgu,ts) ->
  3399:             (*
  3400:             print_endline "handle_function (1)";
  3401:             *)
  3402:             let tb : btypecode_t =
  3403:               handle_type
  3404:               syms
  3405:               rs
  3406:               sra srn name ts index
  3407:             in
  3408:               Some tb
  3409:           | None -> None
  3410:           end
  3411: 
  3412:     | `SYMDEF_class ->
  3413:       (*
  3414:       print_endline ("Found a class "^name^", look for constructor with hacked name _ctor_"^name);
  3415:       *)
  3416:       let entries = lookup_name_in_htab pubmap ("_ctor_" ^ name) in
  3417:       begin match entries with
  3418:       | None -> clierr sr "Unable to find any constructors for this class"
  3419:       | Some (`NonFunctionEntry _) -> syserr sr
  3420:         "[lookup_type_name_in_table_dirs_with_sig] Expected constructor to be a procedure"
  3421: 
  3422:       | Some (`FunctionEntry fs) ->
  3423:         (*
  3424:         print_endline ("Ok, found "^si (length fs) ^"constructors for " ^ name);
  3425:         *)
  3426:         let ro =
  3427:           resolve_overload'
  3428:           syms caller_env rs sra fs ("_ctor_" ^ name) t2 ts
  3429:         in
  3430:         match ro with
  3431:           | Some (index,t,ret,mgu,ts) ->
  3432:             print_endline "handle_function (2)";
  3433:             let tb =
  3434:               handle_type
  3435:               syms
  3436:               rs
  3437:               sra srn name ts index
  3438:             in
  3439:               (*
  3440:               print_endline ("SUCCESS: overload chooses " ^ full_string_of_entry_kind syms.dfns index);
  3441:               print_endline ("Value of ts is " ^ catmap "," (sbt syms.dfns) ts);
  3442:               print_endline ("Instantiated closure value is " ^ sbe syms.dfns tb);
  3443:               print_endline ("type is " ^ sbt syms.dfns tt);
  3444:               *)
  3445:               Some tb
  3446:           | None ->
  3447:             clierr sr "Unable to find matching constructor"
  3448:       end
  3449: 
  3450:     | `SYMDEF_typevar mt ->
  3451:       let mt = bt sra mt in
  3452:       (* match function a -> b -> c -> d with sigs a b c *)
  3453:       let rec m f s = match f,s with
  3454:       | `BTYP_function (d,c),h::t when d = h -> m c t
  3455:       | `BTYP_typefun _,_ -> failwith "Can't handle actual lambda form yet"
  3456:       | _,[] -> true
  3457:       | _ -> false
  3458:       in
  3459:       if m mt t2
  3460:       then Some (`BTYP_var (sye index,mt))
  3461:       else
  3462:       (print_endline
  3463:       (
  3464:         "Typevariable has wrong meta-type" ^
  3465:         "\nexpected domains " ^ catmap ", " (sbt syms.dfns) t2 ^
  3466:         "\ngot " ^ sbt syms.dfns mt
  3467:       ); None)
  3468: 
  3469:     | `SYMDEF_abs _
  3470:     | `SYMDEF_cclass _
  3471:     | `SYMDEF_union _
  3472:     | `SYMDEF_type_alias _ ->
  3473:       print_endline "Found abs,cclass, union or alias";
  3474:       Some (`BTYP_inst (sye index, ts))
  3475: 
  3476: 
  3477:     | `SYMDEF_const_ctor _
  3478:     | `SYMDEF_const _
  3479:     | `SYMDEF_var _
  3480:     | `SYMDEF_ref _
  3481:     | `SYMDEF_val _
  3482:     | `SYMDEF_parameter _
  3483:     | `SYMDEF_axiom _
  3484:     | `SYMDEF_lemma _
  3485:     | `SYMDEF_callback _
  3486:     | `SYMDEF_fun _
  3487:     | `SYMDEF_function _
  3488:     | `SYMDEF_glr _
  3489:     | `SYMDEF_insert _
  3490:     | `SYMDEF_instance _
  3491:     | `SYMDEF_lazy _
  3492:     | `SYMDEF_match_check _
  3493:     | `SYMDEF_module
  3494:     | `SYMDEF_newtype _
  3495:     | `SYMDEF_reduce _
  3496:     | `SYMDEF_regdef _
  3497:     | `SYMDEF_regmatch _
  3498:     | `SYMDEF_reglex _
  3499:     | `SYMDEF_typeclass
  3500:       ->
  3501:         clierr sra
  3502:         (
  3503:           "[lookup_type_name_in_table_dirs_with_sig] Expected " ^id^
  3504:           " to be a type or functor, got " ^
  3505:           string_of_symdef entry id vs
  3506:         )
  3507:     end
  3508:     end
  3509: 
  3510:   | `FunctionEntry fs ->
  3511:     (*
  3512:     print_endline ("Found function set size " ^ si (length fs));
  3513:     *)
  3514:     let ro =
  3515:       resolve_overload'
  3516:       syms caller_env rs sra fs name t2 ts
  3517:     in
  3518:     match ro with
  3519:       | Some (index,t,ret,mgu,ts) ->
  3520:         (*
  3521:         print_endline ("handle_function (3) ts=" ^ catmap "," (sbt syms.dfns) ts);
  3522:         let ts = adjust_ts syms sra index ts in
  3523:         print_endline "Adjusted ts";
  3524:         print_endline ("Found functional thingo, " ^ si index);
  3525:         print_endline (" ts=" ^ catmap "," (sbt syms.dfns) ts);
  3526:         *)
  3527: 
  3528:         let tb =
  3529:           handle_type
  3530:           syms
  3531:           rs
  3532:           sra srn name ts index
  3533:         in
  3534:           (*
  3535:           print_endline ("SUCCESS: overload chooses " ^ full_string_of_entry_kind syms.dfns (mkentry syms dfltvs index));
  3536:           print_endline ("Value of ts is " ^ catmap "," (sbt syms.dfns) ts);
  3537:           print_endline ("Instantiated type is " ^ sbt syms.dfns tb);
  3538:           *)
  3539:           Some tb
  3540: 
  3541:       | None ->
  3542:         (*
  3543:         print_endline "Can't overload: Trying opens";
  3544:         *)
  3545:         let opens : entry_set_t list =
  3546:           concat
  3547:           (
  3548:             map
  3549:             (fun table ->
  3550:               match lookup_name_in_htab table name with
  3551:               | Some x -> [x]
  3552:               | None -> []
  3553:             )
  3554:             dirs
  3555:           )
  3556:         in
  3557:         (*
  3558:         print_endline (si (length opens) ^ " OPENS BUILT for " ^ name);
  3559:         *)
  3560:         match opens with
  3561:         | [`NonFunctionEntry i] when
  3562:           (
  3563:               match get_data syms.dfns (sye i) with
  3564:               {id=id;sr=sr;parent=parent;vs=vs;pubmap=pubmap;symdef=entry}->
  3565:               (*
  3566:               print_endline ("FOUND " ^ id);
  3567:               *)
  3568:               match entry with
  3569:               | `SYMDEF_abs _
  3570:               | `SYMDEF_cclass _
  3571:               | `SYMDEF_union _ -> true
  3572:               | _ -> false
  3573:            ) ->
  3574:            Some (`BTYP_inst (sye i, ts))
  3575: 
  3576:         | _ ->
  3577:         let fs =
  3578:           match opens with
  3579:           | [`NonFunctionEntry i] -> [i]
  3580:           | [`FunctionEntry ii] -> ii
  3581:           | _ ->
  3582:             merge_functions opens name
  3583:         in
  3584:           let ro =
  3585:             resolve_overload'
  3586:             syms caller_env rs sra fs name t2 ts
  3587:           in
  3588:           (*
  3589:           print_endline "OVERLOAD RESOLVED .. ";
  3590:           *)
  3591:           match ro with
  3592:           | Some (result,t,ret,mgu,ts) ->
  3593:             (*
  3594:             print_endline "handle_function (4)";
  3595:             *)
  3596:             let tb : btypecode_t =
  3597:               handle_type
  3598:               syms
  3599:               rs
  3600:               sra srn name ts result
  3601:             in
  3602:               Some tb
  3603:           | None ->
  3604:             (*
  3605:             print_endline "FAILURE"; flush stdout;
  3606:             *)
  3607:             None
  3608: 
  3609: and bind_regdef syms env regexp_exclude e =
  3610:   let bd e = bind_regdef syms env regexp_exclude e in
  3611:   match e with
  3612:   | `REGEXP_group (n,e) -> `REGEXP_group (n, bd e)
  3613:   | `REGEXP_seq (e1,e2) -> `REGEXP_seq (bd e1, bd e2)
  3614:   | `REGEXP_alt (e1,e2) -> `REGEXP_alt (bd e1, bd e2)
  3615:   | `REGEXP_aster e -> `REGEXP_aster (bd e)
  3616:   | `REGEXP_name qn ->
  3617:     begin match lookup_qn_in_env syms env qn with
  3618:     | i,_ ->
  3619:       if mem (sye i) regexp_exclude
  3620:       then
  3621:         let sr = src_of_expr (qn:>expr_t) in
  3622:         clierr sr
  3623:         (
  3624:           "[bind_regdef] Regdef " ^ string_of_qualified_name qn ^
  3625:           " depends on itself"
  3626:         )
  3627:       else
  3628:         begin
  3629:           match get_data syms.dfns (sye i) with
  3630:           {symdef=entry} ->
  3631:           match entry with
  3632:           | `SYMDEF_regdef e ->
  3633:             let mkenv i = build_env syms (Some i) in
  3634:             let env = mkenv (sye i) in
  3635:             bind_regdef syms env ((sye i)::regexp_exclude) e
  3636:           | _ ->
  3637:             let sr = src_of_expr (qn:>expr_t) in
  3638:             clierr sr
  3639:             (
  3640:               "[bind_regdef] Expected " ^ string_of_qualified_name qn ^
  3641:               " to be regdef"
  3642:             )
  3643:         end
  3644:     end
  3645: 
  3646:   | x -> x
  3647: 
  3648: and handle_map sr (f,ft) (a,at) =
  3649:     let t =
  3650:       match ft with
  3651:       | `BTYP_function (d,c) ->
  3652:         begin match at with
  3653:         | `BTYP_inst (i,[t]) ->
  3654:           if t <> d
  3655:           then clierr sr
  3656:             ("map type of data structure index " ^
  3657:             "must agree with function domain")
  3658:           else
  3659:             `BTYP_inst (i,[c])
  3660:         | _ -> clierr sr "map requires instance"
  3661:         end
  3662:       | _ -> clierr sr "map non-function"
  3663:     in
  3664:       (* actually this part is easy, it's just
  3665:       applies ((map[i] f) a) where map[i] denotes
  3666:       the map function generated for data structure i
  3667:       *)
  3668:       failwith "MAP NOT IMPLEMENTED"
  3669: 
  3670: and bind_expression_with_args syms env e args : tbexpr_t =
  3671:   bind_expression' syms env rsground e args
  3672: 
  3673: and bind_expression' syms env (rs:recstop) e args : tbexpr_t =
  3674:   let sr = src_of_expr e in
  3675:   (*
  3676:   print_endline ("[bind_expression'] " ^ string_of_expr e);
  3677:   print_endline ("expr_fixlist is " ^
  3678:     catmap ","
  3679:     (fun (e,d) -> string_of_expr e ^ " [depth " ^si d^"]")
  3680:     rs.expr_fixlist
  3681:   );
  3682:   *)
  3683:   if mem_assq e rs.expr_fixlist
  3684:   then raise (Expr_recursion e)
  3685:   ;
  3686:   let be e' = bind_expression' syms env
  3687:     { rs with expr_fixlist=(e,rs.depth)::rs.expr_fixlist; depth=rs.depth+1} e' [] in
  3688:   let mkenv i = build_env syms (Some i) in
  3689:   let bt sr t =
  3690:     (* we're really wanting to call bind type and propagate depth ? *)
  3691:     let t = bind_type' syms env
  3692:       { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist; depth=rs.depth +1 }
  3693:       sr t [] mkenv
  3694:     in
  3695:     let t = beta_reduce syms sr t in
  3696:     t
  3697:   in
  3698:   let ti sr i ts =
  3699:     inner_typeofindex_with_ts syms sr
  3700:     { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist; depth = rs.depth + 1}
  3701:                                (* CHANGED THIS ------------------*******)
  3702:     i ts
  3703:   in
  3704: 
  3705:   (* model infix operator as function call *)
  3706:   let apl2 (sri:range_srcref) (fn : string) (tup:expr_t list) =
  3707:     let sr = rslist tup in
  3708:     `AST_apply
  3709:     (
  3710:       sr,
  3711:       (
  3712:         `AST_name (sri,fn,[]),
  3713:         `AST_tuple (sr,tup)
  3714:       )
  3715:     )
  3716:   in
  3717:   (*
  3718:   print_endline ("Binding expression " ^ string_of_expr e ^ " depth=" ^ string_of_int depth);
  3719:   print_endline ("environment is:");
  3720:   print_env env;
  3721:   print_endline "==";
  3722:   *)
  3723:   let rt t = Flx_maps.reduce_type (lstrip syms.dfns (beta_reduce syms sr t)) in
  3724:   let sr = src_of_expr e in
  3725:   match e with
  3726:   | `AST_patvar _
  3727:   | `AST_patany _
  3728:   | `AST_case _
  3729:   | `AST_interpolate _
  3730:   | `AST_vsprintf _
  3731:   | `AST_type_match _
  3732:   | `AST_noexpand _
  3733:   | `AST_letin _
  3734:   | `AST_cond _
  3735:   | `AST_typeof _
  3736:   | `AST_as _
  3737:   | `AST_void _
  3738:   | `AST_arrow _
  3739:   | `AST_longarrow _
  3740:   | `AST_superscript _
  3741:   | `AST_ellipsis _
  3742:   | `AST_parse _
  3743:   | `AST_setunion _
  3744:   | `AST_setintersection _
  3745:   | `AST_macro_ctor _
  3746:   | `AST_macro_statements  _
  3747:   | `AST_lift _
  3748:     ->
  3749:       clierr sr
  3750:      ("[bind_expression] Expected expression, got " ^ string_of_expr e)
  3751: 
  3752:   | `AST_apply (sr,(`AST_name (_,"_tuple_flatten",[]),e)) ->
  3753:     let result = ref [] in
  3754:     let stack = ref [] in
  3755:     let push () = stack := 0 :: !stack in
  3756:     let pop () = stack := tl (!stack) in
  3757:     let inc () =
  3758:       match !stack with
  3759:       | [] -> ()
  3760:       | _ -> stack := hd (!stack) + 1 :: tl (!stack)
  3761:     in
  3762:     let rec term stack = match stack with
  3763:       | [] -> e
  3764:       | _ -> `AST_get_n (sr, (hd stack, term (tl stack)))
  3765:     in
  3766:     let _,t = be e in
  3767:     let rec aux t = match t with
  3768:     | `BTYP_tuple ls ->
  3769:       push (); iter aux ls; pop(); inc ()
  3770: 
  3771:     | `BTYP_array (t,`BTYP_unitsum n) when n < 20 ->
  3772:       push(); for i = 0 to n-1 do aux t done; pop(); inc();
  3773: 
  3774:     | _ ->
  3775:       result := term (!stack) :: !result;
  3776:       inc ()
  3777:     in
  3778:     aux t;
  3779:     let e = `AST_tuple (sr,rev (!result)) in
  3780:     be e
  3781: 
  3782:   | `AST_apply (sr,(`AST_name (_,"_tuple_trans",[]),e)) ->
  3783:     let tr nrows ncolumns =
  3784:       let e' = ref [] in
  3785:       for i = nrows - 1 downto 0 do
  3786:         let x = ref [] in
  3787:         for j = ncolumns - 1 downto 0 do
  3788:           let v = `AST_get_n (sr,(i,`AST_get_n (sr,(j,e)))) in
  3789:           x := v :: !x;
  3790:         done;
  3791:         e' := `AST_tuple (sr,!x) :: (!e');
  3792:       done
  3793:       ;
  3794:       be (`AST_tuple (sr,!e'))
  3795:     in
  3796:     let calnrows t =
  3797:       let nrows =
  3798:         match t with
  3799:         | `BTYP_tuple ls -> length ls
  3800:         | `BTYP_array (_,`BTYP_unitsum n) -> n
  3801:         | _ -> clierrn [sr] "Tuple transpose requires entry to be tuple"
  3802:       in
  3803:       if nrows < 2 then
  3804:         clierr sr "Tuple transpose requires tuple argument with 2 or more elements"
  3805:       ;
  3806:       nrows
  3807:     in
  3808:     let colchk nrows t =
  3809:       match t with
  3810:       | `BTYP_tuple ls ->
  3811:         if length ls != nrows then
  3812:           clierr sr ("Tuple transpose requires entry to be tuple of length " ^ si nrows)
  3813: 
  3814:       | `BTYP_array (_,`BTYP_unitsum n) ->
  3815:         if n != nrows then
  3816:           clierr sr ("Tuple transpose requires entry to be tuple of length " ^ si nrows)
  3817: 
  3818:       | _ -> clierr sr "Tuple transpose requires entry to be tuple"
  3819:     in
  3820:     let _,t = be e in
  3821:     let ncolumns, nrows =
  3822:       match t with
  3823:       | `BTYP_tuple ls ->
  3824:         let ncolumns  = length ls in
  3825:         let nrows = calnrows (hd ls) in
  3826:         iter (colchk nrows) ls;
  3827:         ncolumns, nrows
  3828: 
  3829:       | `BTYP_array (t,`BTYP_unitsum ncolumns) ->
  3830:         let nrows = calnrows t in
  3831:         ncolumns, nrows
  3832: 
  3833:       | _ -> clierr sr "Tuple transpose requires tuple argument"
  3834:     in
  3835:       if nrows > 20 then
  3836:         clierr sr ("tuple fold: row bound " ^ si nrows ^ ">20, to large")
  3837:       ;
  3838:       if ncolumns> 20 then
  3839:         clierr sr ("tuple fold: column bound " ^ si ncolumns^ ">20, to large")
  3840:       ;
  3841:       tr nrows ncolumns
  3842: 
  3843:   | `AST_apply
  3844:     (
  3845:       sr,
  3846:       (
  3847:         `AST_apply
  3848:         (
  3849:           _,
  3850:           (
  3851:             `AST_apply ( _, ( `AST_name(_,"_tuple_fold",[]), f)),
  3852:             i
  3853:           )
  3854:         ),
  3855:         c
  3856:       )
  3857:     ) ->
  3858: 
  3859: 
  3860:     let _,t = be c in
  3861:     let calfold n =
  3862:       let rec aux m result =
  3863:         if m = 0 then result else
  3864:         let  k = n-m in
  3865:         let arg = `AST_get_n (sr,(k,c)) in
  3866:         let arg = `AST_tuple (sr,[result; arg]) in
  3867:         aux (m-1) (`AST_apply(sr,(f,arg)))
  3868:       in be (aux n i)
  3869:     in
  3870:     begin match t with
  3871:     | `BTYP_tuple ts  -> calfold (length ts)
  3872:     | `BTYP_array (_,`BTYP_unitsum n) ->
  3873:        if  n<20 then calfold n
  3874:        else
  3875:          clierr sr ("Tuple fold array length " ^ si n ^ " too big, limit 20")
  3876: 
  3877:     | _ -> clierr sr "Tuple fold requires tuple argument"
  3878:     end
  3879: 
  3880: 
  3881:   | `AST_callback (sr,qn) ->
  3882:     let es,ts = lookup_qn_in_env2' syms env rs qn in
  3883:     begin match es with
  3884:     | `FunctionEntry [index] ->
  3885:        print_endline "Callback closure ..";
  3886:        let ts = map (bt sr) ts in
  3887:        `BEXPR_closure (sye index, ts),
  3888:        ti sr (sye index) ts
  3889:     | `NonFunctionEntry  _
  3890:     | _ -> clierr sr
  3891:       "'callback' expression denotes non-singleton function set"
  3892:     end
  3893: 
  3894:   | `AST_sparse (sr,e,nt,nts) ->
  3895:     let e = be e in
  3896:     (*
  3897:     print_endline ("Calculating AST_parse, symbol " ^ nt);
  3898:     *)
  3899:     let t = cal_glr_attr_type syms sr nts in
  3900:     (*
  3901:     print_endline (".. DONE: Calculating AST_parse, type=" ^ sbt syms.dfns t);
  3902:     *)
  3903:     `BEXPR_parse (e,nts),`BTYP_sum [unit_t;t]
  3904: 
  3905:   | `AST_expr (sr,s,t) ->
  3906:     let t = bt sr t in
  3907:     `BEXPR_expr (s,t),t
  3908: 
  3909:   | `AST_andlist (sri,ls) ->
  3910:     begin let mksum a b = apl2 sri "land" [a;b] in
  3911:     match ls with
  3912:     | h::t -> be (fold_left mksum h t)
  3913:     | [] -> clierr sri "Not expecting empty and list"
  3914:     end
  3915: 
  3916:   | `AST_orlist (sri,ls) ->
  3917:     begin let mksum a b = apl2 sri "lor" [a;b] in
  3918:     match ls with
  3919:     | h::t -> be (fold_left mksum h t)
  3920:     | [] -> clierr sri "Not expecting empty or list"
  3921:     end
  3922: 
  3923:   | `AST_sum (sri,ls) ->
  3924:     begin let mksum a b = apl2 sri "add" [a;b] in
  3925:     match ls with
  3926:     | h::t -> be (fold_left mksum h t)
  3927:     | [] -> clierr sri "Not expecting empty product (unit)"
  3928:     end
  3929: 
  3930:   | `AST_product (sri,ls) ->
  3931:     begin let mkprod a b = apl2 sri "mul" [a;b] in
  3932:     match ls with
  3933:     | h::t -> be (fold_left mkprod h t)
  3934:     | [] -> clierr sri "Not expecting empty sum (void)"
  3935:     end
  3936: 
  3937:   | `AST_coercion (sr,(x,t)) ->
  3938:     let (e',t') as x' = be x in
  3939:     let t'' = bt sr t in
  3940:     if type_eq syms.dfns t' t'' then x'
  3941:     else
  3942:     let t' = Flx_maps.reduce_type t' in (* src *)
  3943:     let t'' = Flx_maps.reduce_type t'' in (* dst *)
  3944:     begin match t',t'' with
  3945:     | `BTYP_lvalue(`BTYP_inst (i,[])),`BTYP_unitsum n
  3946:     | `BTYP_inst (i,[]),`BTYP_unitsum n ->
  3947:       begin match Hashtbl.find syms.dfns i with
  3948:       | { id="int"; symdef=`SYMDEF_abs (_,`StrTemplate "int",_) }  ->
  3949:         begin match e' with
  3950:         | `BEXPR_literal (`AST_int (kind,big)) ->
  3951:           let m =
  3952:             try Big_int.int_of_big_int big
  3953:             with _ -> clierr sr "Integer is too large for unitsum"
  3954:           in
  3955:           if m >=0 && m < n then
  3956:             `BEXPR_case (m,t''),t''
  3957:           else
  3958:             clierr sr "Integer is out of range for unitsum"
  3959:         | _ ->
  3960:           let inttype = t' in
  3961:           let zero = `BEXPR_literal (`AST_int ("int",Big_int.zero_big_int)),t' in
  3962:           let xn = `BEXPR_literal (`AST_int ("int",Big_int.big_int_of_int n)),t' in
  3963:           `BEXPR_range_check (zero,x',xn),`BTYP_unitsum n
  3964: 
  3965:         end
  3966:       | _ ->
  3967:         clierr sr ("Attempt to to coerce type:\n"^
  3968:         sbt syms.dfns t'
  3969:         ^"to unitsum " ^ si n)
  3970:       end
  3971: 
  3972:     | `BTYP_lvalue(`BTYP_record ls'),`BTYP_record ls''
  3973:     | `BTYP_record ls',`BTYP_record ls'' ->
  3974:       begin
  3975:       try
  3976:       `BEXPR_record
  3977:       (
  3978:         map
  3979:         (fun (s,t)->
  3980:           match list_assoc_index ls' s with
  3981:           | Some j ->
  3982:             let tt = assoc s ls' in
  3983:             if type_eq syms.dfns t tt then
  3984:               s,(`BEXPR_get_n (j,x'),t)
  3985:             else clierr sr (
  3986:               "Source Record field '" ^ s ^ "' has type:\n" ^
  3987:               sbt syms.dfns tt ^ "\n" ^
  3988:               "but coercion target has the different type:\n" ^
  3989:               sbt syms.dfns t ^"\n" ^
  3990:               "The types must be the same!"
  3991:             )
  3992:           | None -> raise Not_found
  3993:         )
  3994:         ls''
  3995:       ),
  3996:       t''
  3997:       with Not_found ->
  3998:         clierr sr
  3999:          (
  4000:          "Record coercion dst requires subset of fields of src:\n" ^
  4001:          sbe syms.dfns x' ^ " has type " ^ sbt syms.dfns t' ^
  4002:         "\nwhereas annotation requires " ^ sbt syms.dfns t''
  4003:         )
  4004:       end
  4005: 
  4006:     | `BTYP_lvalue(`BTYP_variant lhs),`BTYP_variant rhs
  4007:     | `BTYP_variant lhs,`BTYP_variant rhs ->
  4008:       begin
  4009:       try
  4010:         iter
  4011:         (fun (s,t)->
  4012:           match list_assoc_index rhs s with
  4013:           | Some j ->
  4014:             let tt = assoc s rhs in
  4015:             if not (type_eq syms.dfns t tt) then
  4016:             clierr sr (
  4017:               "Source Variant field '" ^ s ^ "' has type:\n" ^
  4018:               sbt syms.dfns t ^ "\n" ^
  4019:               "but coercion target has the different type:\n" ^
  4020:               sbt syms.dfns tt ^"\n" ^
  4021:               "The types must be the same!"
  4022:             )
  4023:           | None -> raise Not_found
  4024:         )
  4025:         lhs
  4026:         ;
  4027:         print_endline ("Coercion of variant to type " ^ sbt syms.dfns t'');
  4028:         `BEXPR_coerce (x',t''),t''
  4029:       with Not_found ->
  4030:         clierr sr
  4031:          (
  4032:          "Variant coercion src requires subset of fields of dst:\n" ^
  4033:          sbe syms.dfns x' ^ " has type " ^ sbt syms.dfns t' ^
  4034:         "\nwhereas annotation requires " ^ sbt syms.dfns t''
  4035:         )
  4036:       end
  4037:     | _ ->
  4038:       clierr sr
  4039:       (
  4040:         "Wrong type in coercion:\n" ^
  4041:         sbe syms.dfns x' ^ " has type " ^ sbt syms.dfns t' ^
  4042:         "\nwhereas annotation requires " ^ sbt syms.dfns t''
  4043:       )
  4044:     end
  4045: 
  4046:   | `AST_get_n (sr,(n,e')) ->
  4047:     let expr,typ = be e' in
  4048:     let ctyp = match unfold syms.dfns typ with
  4049:     | `BTYP_array (t,`BTYP_unitsum len)  ->
  4050:       if n<0 or n>len-1
  4051:       then clierr sr
  4052:         (
  4053:           "[bind_expression] Tuple index " ^
  4054:           string_of_int n ^
  4055:           " out of range 0.." ^
  4056:           string_of_int (len-1)
  4057:         )
  4058:       else t
  4059: 
  4060:     | `BTYP_lvalue (`BTYP_array (t,`BTYP_unitsum len)) ->
  4061:       if n<0 or n>len-1
  4062:       then clierr sr
  4063:         (
  4064:           "[bind_expression] Tuple index " ^
  4065:           string_of_int n ^
  4066:           " out of range 0.." ^
  4067:           string_of_int (len-1)
  4068:         )
  4069:       else lvalify t
  4070: 
  4071: 
  4072:     | `BTYP_tuple ts
  4073:     | `BTYP_lvalue (`BTYP_tuple ts)
  4074:       ->
  4075:       let len = length ts in
  4076:       if n<0 or n>len-1
  4077:       then clierr sr
  4078:         (
  4079:           "[bind_expression] Tuple index " ^
  4080:           string_of_int n ^
  4081:           " out of range 0.." ^
  4082:           string_of_int (len-1)
  4083:         )
  4084:       else nth ts n
  4085:     | _ ->
  4086:       clierr sr
  4087:       (
  4088:         "[bind_expression] Expected tuple " ^
  4089:         string_of_expr e' ^
  4090:         " to have tuple type, got " ^
  4091:         sbt syms.dfns typ
  4092:       )
  4093:     in
  4094:       `BEXPR_get_n (n, (expr,typ)), ctyp
  4095: 
  4096:   | `AST_get_named_variable (sr,(name,e')) ->
  4097:     let e'',t'' as x2 = be e' in
  4098:     begin match t'' with
  4099:     | `BTYP_record es
  4100:     | `BTYP_lvalue (`BTYP_record es) ->
  4101:       let rcmp (s1,_) (s2,_) = compare s1 s2 in
  4102:       let es = sort rcmp es in
  4103:       let field_name = name in
  4104:       begin match list_index (map fst es) field_name with
  4105:       | Some n -> `BEXPR_get_n (n,x2),assoc field_name es
  4106:       | None -> clierr sr
  4107:          (
  4108:            "Field " ^ field_name ^
  4109:            " is not a member of anonymous structure " ^
  4110:            sbt syms.dfns t''
  4111:           )
  4112:       end
  4113: 
  4114:     | `BTYP_inst (i,ts)
  4115:     | `BTYP_lvalue (`BTYP_inst (i,ts)) ->
  4116:       begin match Hashtbl.find syms.dfns i with
  4117:       | { privmap=privtab; symdef = `SYMDEF_class } ->
  4118:         (*
  4119:         print_endline "AST_get_named finds a class .. ";
  4120:         print_endline ("Looking for component named " ^ name);
  4121:         *)
  4122:         let entryset =
  4123:           try Hashtbl.find privtab name
  4124:           with Not_found -> clierr sr
  4125:             ("[lookup:get_named_variable] Cannot find variable " ^
  4126:               name ^ " in class"
  4127:             )
  4128:         in
  4129:         begin match entryset with
  4130:         | `NonFunctionEntry idx ->
  4131:           let idx = sye idx in
  4132:           let vtype =
  4133:             inner_typeofindex_with_ts syms sr
  4134:             { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist; depth = rs.depth+1 }
  4135:             idx ts
  4136:            in
  4137:            (*
  4138:            print_endline ("Class member variable has type " ^ sbt syms.dfns vtype);
  4139:            *)
  4140:            `BEXPR_get_named (idx,(e'',t'')),vtype
  4141:         | _ -> clierr sr ("Expected component "^name^" to be a variable")
  4142:         end
  4143:       | _ -> clierr sr ("[bind_expression] Projection requires class")
  4144:       end
  4145:     | _ -> clierr sr ("[bind_expression] Projection requires class instance")
  4146:     end
  4147: 
  4148:   | `AST_get_named_method (sr,(meth_name,meth_idx,meth_ts,obj)) ->
  4149:     (*
  4150:     print_endline ("Get named method " ^ meth_name);
  4151:     *)
  4152:     let meth_ts = map (bt sr) meth_ts in
  4153:     let oe,ot = be obj in
  4154:     begin match ot with
  4155:     | `BTYP_inst (oi,ots)
  4156:     | `BTYP_lvalue (`BTYP_inst (oi,ots)) ->
  4157: 
  4158:       (*
  4159:       (* bind the method signature in the context of the object *)
  4160:       let sign =
  4161:         let entry = Hashtbl.find syms.dfns oi in
  4162:         match entry with | {vs = vs } ->
  4163:         let bvs = map (fun (n,i,_) -> n,`BTYP_var (i,`BTYP_type 0)) (fst vs) in
  4164:         print_endline ("Binding sign = " ^ string_of_typecode sign);
  4165:         let env' = build_env syms (Some oi) in
  4166:         bind_type' syms env' rsground sr sign bvs mkenv
  4167:       in
  4168:       print_endline ("Got sign bound = " ^ sbt syms.dfns sign);
  4169:       *)
  4170:       begin match Hashtbl.find syms.dfns oi with
  4171:       | {id=classname; privmap=privtab;
  4172:          vs=obj_vs; symdef = `SYMDEF_class } ->
  4173:         (*
  4174:         print_endline ("AST_get_named finds a class .. " ^ classname);
  4175:         print_endline ("Looking for component named " ^ name);
  4176:         *)
  4177:         let entryset =
  4178:           try Hashtbl.find privtab meth_name
  4179:           (* try Hashtbl.find pubtab meth_name  *)
  4180:           with Not_found -> clierr sr
  4181:             ("[lookup: get_named_method] Cannot find method " ^
  4182:             meth_name ^ " in class " ^ classname
  4183:             )
  4184:         in
  4185:         begin match entryset with
  4186:         | `FunctionEntry fs ->
  4187:           if not (mem meth_idx (map sye fs)) then syserr sr "Woops, method index isn't a member function!";
  4188:           begin match Hashtbl.find syms.dfns meth_idx with
  4189:           | {id=method_name; vs=meth_vs; symdef = `SYMDEF_function _} ->
  4190:             assert (meth_name = method_name);
  4191:             (*
  4192:             print_endline ("Found " ^ si (length fs) ^ " candidates");
  4193:             print_endline ("Object ts=" ^ catmap "," (sbt syms.dfns) ots);
  4194:             print_endline ("Object vs = " ^ print_ivs_with_index obj_vs);
  4195:             print_endline ("Method ts=" ^ catmap "," (sbt syms.dfns) meth_ts);
  4196:             print_endline ("Method vs = " ^ print_ivs_with_index meth_vs);
  4197:             *)
  4198:             (*
  4199:             begin match resolve_overload' syms env rs sr fs meth_name [sign] meth_ts with
  4200:             | Some (meth_idx,meth_dom,meth_ret,mgu,meth_ts) ->
  4201:               (*
  4202:               print_endline "Overload resolution OK";
  4203:               *)
  4204:               (* Now we need to fixate the class type variables in the method *)
  4205:               *)
  4206:               (*
  4207:               print_endline ("ots = " ^ catmap "," (sbt syms.dfns) ots);
  4208:               *)
  4209:               let omap =
  4210:                 let vars = map2 (fun (_,i,_) t -> i,t) (fst obj_vs) ots in
  4211:                 hashtable_of_list vars
  4212:               in
  4213:               let meth_ts = map (varmap_subst omap) meth_ts in
  4214:               (*
  4215:               print_endline ("meth_ts = " ^ catmap "," (sbt syms.dfns) meth_ts);
  4216:               *)
  4217:               let ts = ots @ meth_ts in
  4218:               let typ = typeofindex_with_ts syms sr meth_idx ts in
  4219:               `BEXPR_method_closure ((oe,ot),meth_idx,ts),typ
  4220: 
  4221: 
  4222:             (*
  4223:             | _ -> clierr sr
  4224:               ("[lookup: get_named_method] Cannot find method " ^ meth_name ^
  4225:                 " with signature "^sbt syms.dfns sign^" in class, candidates are:\n" ^
  4226:                 catmap "," (fun i -> meth_name ^ "<" ^si i^ ">") fs
  4227:               )
  4228:           end
  4229:           *)
  4230:           | _ -> clierr sr ("[get_named_method] Can't find method "^meth_name)
  4231:           end
  4232:         | _ -> clierr sr ("Expected component "^meth_name^" to be a function")
  4233:         end
  4234:       | _ -> clierr sr ("[bind_expression] Projection requires class")
  4235:       end
  4236:     | _ -> clierr sr ("[bind_expression] Projection requires class instance")
  4237:     end
  4238: 
  4239:   | `AST_case_index (sr,e) ->
  4240:     let (e',t) as e  = be e in
  4241:     begin match lstrip syms.dfns t with
  4242:     | `BTYP_unitsum _ -> ()
  4243:     | `BTYP_sum _ -> ()
  4244:     | `BTYP_variant _ -> ()
  4245:     | `BTYP_inst (i,_) ->
  4246:       begin match Hashtbl.find syms.dfns i with
  4247:       | {symdef=`SYMDEF_union _} -> ()
  4248:       | {id=id} -> clierr sr ("Argument of caseno must be sum or union type, got type " ^ id)
  4249:       end
  4250:     | _ -> clierr sr ("Argument of caseno must be sum or union type, got " ^ sbt syms.dfns t)
  4251:     end
  4252:     ;
  4253:     let int_t = bt sr (`AST_name (sr,"int",[])) in
  4254:     begin match e' with
  4255:     | `BEXPR_case (i,_) ->
  4256:       `BEXPR_literal (`AST_int ("int",Big_int.big_int_of_int i))
  4257:     | _ -> `BEXPR_case_index e
  4258:     end
  4259:     ,
  4260:     int_t
  4261: 
  4262:   | `AST_case_tag (sr,v) ->
  4263:      clierr sr "plain case tag not allowed in expression (only in pattern)"
  4264: 
  4265:   | `AST_variant (sr,(s,e)) ->
  4266:     let (_,t) as e = be e in
  4267:     `BEXPR_variant (s,e),`BTYP_variant [s,t]
  4268: 
  4269:   | `AST_typed_case (sr,v,t) ->
  4270:     let t = bt sr t in
  4271:     ignore (try unfold syms.dfns t with _ -> failwith "AST_typed_case unfold screwd");
  4272:     begin match unfold syms.dfns t with
  4273:     | `BTYP_unitsum k ->
  4274:       if v<0 or v>= k
  4275:       then clierr sr "Case index out of range of sum"
  4276:       else
  4277:         `BEXPR_case (v,t),t  (* const ctor *)
  4278: 
  4279:     | `BTYP_sum ls ->
  4280:       if v<0 or v>= length ls
  4281:       then clierr sr "Case index out of range of sum"
  4282:       else let vt = nth ls v in
  4283:       let ct =
  4284:         match vt with
  4285:         | `BTYP_tuple [] -> t        (* const ctor *)
  4286:         | _ -> `BTYP_function (vt,t) (* non-const ctor *)
  4287:       in
  4288:       `BEXPR_case (v,t), ct
  4289:     | _ ->
  4290:       clierr sr
  4291:       (
  4292:         "[bind_expression] Type of case must be sum, got " ^
  4293:         sbt syms.dfns t
  4294:       )
  4295:     end
  4296: 
  4297:   | `AST_name (sr,name,ts) ->
  4298:     (*
  4299:     print_endline ("BINDING NAME " ^ name);
  4300:     *)
  4301:     if name = "_felix_type_name" then
  4302:        let sname = catmap "," string_of_typecode ts in
  4303:        let x = `AST_literal (sr,`AST_string sname) in
  4304:        be x
  4305:     else
  4306:     let ts = map (bt sr) ts in
  4307:     begin match inner_lookup_name_in_env syms env rs sr name with
  4308:     | `NonFunctionEntry (index) ->
  4309:       let index = sye index in
  4310:       let ts = adjust_ts syms sr index ts in
  4311:       `BEXPR_name (index,ts),
  4312:       let t = ti sr index ts in
  4313:       t
  4314: 
  4315:     | `FunctionEntry fs ->
  4316:       assert (length fs > 0);
  4317:       begin match args with
  4318:       | [] ->
  4319:         clierr sr
  4320:         (
  4321:           "[bind_expression] Simple name " ^ name ^
  4322:           " binds to function set in\n" ^
  4323:           short_string_of_src sr
  4324:         )
  4325:       | args ->
  4326:         let sufs = map snd args in
  4327:         let rs = { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist } in
  4328:         let ro = resolve_overload' syms env rs sr fs name sufs ts in
  4329:         begin match ro with
  4330:          | Some (index, dom,ret,mgu,ts) ->
  4331:            (*
  4332:            print_endline "OK, overload resolved!!";
  4333:            *)
  4334:            `BEXPR_closure (index,ts),
  4335:             ti sr index ts
  4336: 
  4337:          | None -> clierr sr "Cannot resolve overload .."
  4338:         end
  4339:       end
  4340:     end
  4341: 
  4342:   | `AST_index (_,name,index) as x ->
  4343:     (*
  4344:     print_endline ("[bind expression] AST_index " ^ string_of_qualified_name x);
  4345:     *)
  4346:     let ts = adjust_ts syms sr index [] in
  4347:     (*
  4348:     print_endline ("ts=" ^ catmap "," (sbt syms.dfns) ts);
  4349:     *)
  4350:     let t =
  4351:       try ti sr index ts
  4352:       with _ -> print_endline "type of index with ts failed"; raise Not_found
  4353:     in
  4354:     (*
  4355:     print_endline ("Type is " ^ sbt syms.dfns t);
  4356:     *)
  4357:     begin match Hashtbl.find syms.dfns index with
  4358:     | {symdef=`SYMDEF_fun _ }
  4359:     | {symdef=`SYMDEF_function _ }
  4360:     ->
  4361:     (*
  4362:     print_endline ("Indexed name: Binding " ^ name ^ "<"^si index^">"^ " to closure");
  4363:     *)
  4364:       `BEXPR_closure (index,ts),t
  4365:     | _ ->
  4366:     (*
  4367:     print_endline ("Indexed name: Binding " ^ name ^ "<"^si index^">"^ " to variable");
  4368:     *)
  4369:       `BEXPR_name (index,ts),t
  4370:     end
  4371: 
  4372:   | `AST_the(_,`AST_name (sr,name,ts)) ->
  4373:     (*
  4374:     print_endline ("[bind_expression] AST_the " ^ name);
  4375:     print_endline ("AST_name " ^ name ^ "[" ^ catmap "," string_of_typecode ts^ "]");
  4376:     *)
  4377:     let ts = map (bt sr) ts in
  4378:     begin match inner_lookup_name_in_env syms env rs sr name with
  4379:     | `NonFunctionEntry (index) ->
  4380:       let index = sye index in
  4381:       let ts = adjust_ts syms sr index ts in
  4382:       `BEXPR_name (index,ts),
  4383:       let t = ti sr index ts in
  4384:       t
  4385: 
  4386:     | `FunctionEntry [index] ->
  4387:       let index = sye index in
  4388:       let ts = adjust_ts syms sr index ts in
  4389:       `BEXPR_closure (index,ts),
  4390:       let t = ti sr index ts in
  4391:       t
  4392: 
  4393:     | `FunctionEntry _ ->
  4394:       clierr sr
  4395:       (
  4396:         "[bind_expression] Simple 'the' name " ^ name ^
  4397:         " binds to non-singleton function set"
  4398:       )
  4399:     end
  4400:   | `AST_the (sr,q) -> clierr sr "invalid use of 'the' "
  4401: 
  4402:   | (`AST_lookup (sr,(e,name,ts))) as qn ->
  4403:     (*
  4404:     print_endline ("Handling qn " ^ string_of_qualified_name qn);
  4405:     *)
  4406:     let ts = map (bt sr) ts in
  4407:     let entry =
  4408:       match
  4409:           eval_module_expr
  4410:           syms
  4411:           env
  4412:           e
  4413:       with
  4414:       | (Simple_module (impl, ts, htab,dirs)) ->
  4415:         let env' = mk_bare_env syms impl in
  4416:         let tables = get_pub_tables syms env' rs dirs in
  4417:         let result = lookup_name_in_table_dirs htab tables sr name in
  4418:         result
  4419: 
  4420:     in
  4421:       begin match entry with
  4422:       | Some entry ->
  4423:         begin match entry with
  4424:         | `NonFunctionEntry (i) ->
  4425:           let i = sye i in
  4426:           begin match Hashtbl.find syms.dfns i with
  4427:           | {sr=srn; symdef=`SYMDEF_inherit qn} -> be (qn :> expr_t)
  4428:           | _ ->
  4429:             let ts = adjust_ts syms sr i ts in
  4430:             `BEXPR_name (i,ts),
  4431:             ti sr i ts
  4432:           end
  4433: 
  4434:         | `FunctionEntry fs ->
  4435:           begin match args with
  4436:           | [] ->
  4437:             clierr sr
  4438:             (
  4439:               "[bind_expression] Qualified name " ^
  4440:               string_of_qualified_name qn ^
  4441:               " binds to function set"
  4442:             )
  4443: 
  4444:           | args ->
  4445:             let sufs = map snd args in
  4446:             let rs  = { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist } in
  4447:             let ro = resolve_overload' syms env rs sr fs name sufs ts in
  4448:             begin match ro with
  4449:              | Some (index, dom,ret,mgu,ts) ->
  4450:                (*
  4451:                print_endline "OK, overload resolved!!";
  4452:                *)
  4453:                `BEXPR_closure (index,ts),
  4454:                ti sr index ts
  4455: 
  4456:             | None ->
  4457:               clierr sr "Overload resolution failed .. "
  4458:             end
  4459:           end
  4460:         end
  4461: 
  4462:       | None ->
  4463:         clierr sr
  4464:         (
  4465:           "Can't find " ^ name
  4466:         )
  4467:       end
  4468: 
  4469:   | `AST_suffix (sr,(f,suf)) ->
  4470:     let sign = bt sr suf in
  4471:     begin match (f:>expr_t) with
  4472:     | #qualified_name_t as name ->
  4473:       let srn = src_of_expr name in
  4474:       lookup_qn_with_sig'
  4475:         syms
  4476:         sr srn env
  4477:         { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist }
  4478:         name [sign]
  4479: 
  4480:     | e -> be e
  4481:     end
  4482: 
  4483:     (*
  4484:     lookup sr (f:>expr_t) [sign]
  4485:     *)
  4486: 
  4487:   | `AST_ref (_,(`AST_deref (sr,e))) -> be e
  4488: 
  4489:   | `AST_lvalue (srr,e) ->
  4490:     failwith "WOOPS, lvalue in expression??";
  4491: 
  4492:   (* DEPRECATED
  4493:   | `AST_ref (sr,(`AST_dot (_,(e,id,[])))) ->
  4494:   *)
  4495: 
  4496:   (*
  4497:   | `AST_ref (sr,(`AST_dot (_,(e,`AST_name (_,id,[]))))) ->
  4498:     let ref_name = "ref_" ^ id in
  4499:     be
  4500:     (
  4501:       `AST_apply
  4502:       (
  4503:         sr,
  4504:         (
  4505:           `AST_name (sr, ref_name,[]),
  4506:           `AST_ref (sr,e)
  4507:         )
  4508:       )
  4509:     )
  4510:   *)
  4511: 
  4512:   | `AST_ref (srr,e) ->
  4513:     let e',t' = be e in
  4514:     begin match e' with
  4515:     | `BEXPR_name (index,ts) ->
  4516:       begin match get_data syms.dfns index with
  4517:       {id=id; sr=sr; symdef=entry} ->
  4518:       begin match entry with
  4519:       | `SYMDEF_inherit _ -> clierr srr "Woops, bindexpr yielded inherit"
  4520:       | `SYMDEF_inherit_fun _ -> clierr srr "Woops, bindexpr yielded inherit fun"
  4521:       | `SYMDEF_ref _
  4522:       | `SYMDEF_var _
  4523:       | `SYMDEF_parameter (`PVar,_)
  4524:       | `SYMDEF_parameter (`PRef,_) (* not sure if this works .. *)
  4525:         ->
  4526:         let vtype =
  4527:           inner_typeofindex_with_ts syms sr
  4528:           { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist; depth = rs.depth+1 }
  4529:          index ts
  4530:         in
  4531:           `BEXPR_ref (index,ts), `BTYP_pointer vtype
  4532: 
  4533: 
  4534:       | `SYMDEF_parameter _ ->
  4535:          clierr2 srr sr
  4536:         (
  4537:           "[bind_expression] " ^
  4538:           "Address value parameter " ^ id
  4539:         )
  4540:       | `SYMDEF_const _
  4541:       | `SYMDEF_val _ ->
  4542:         clierr2 srr sr
  4543:         (
  4544:           "[bind_expression] " ^
  4545:           "Can't address a value or const " ^ id
  4546:         )
  4547:       | _ ->
  4548:          clierr2 srr sr
  4549:         (
  4550:           "[bind_expression] " ^
  4551:           "Address non variable " ^ id
  4552:         )
  4553:       end
  4554:       end
  4555:     | _ ->
  4556:        clierr srr
  4557:         (
  4558:           "[bind_expression] " ^
  4559:           "Address non variable"
  4560:         )
  4561:     end
  4562: 
  4563:   | `AST_deref (_,`AST_ref (sr,e)) ->
  4564:     let e,t = be e in
  4565:     let t = lvalify t in e,t
  4566: 
  4567:   | `AST_deref (sr,e) ->
  4568:     let e,t = be e in
  4569:     begin match unfold syms.dfns t with
  4570:     | `BTYP_lvalue (`BTYP_pointer t')
  4571:     | `BTYP_pointer t'
  4572:       -> `BEXPR_deref (e,t),`BTYP_lvalue t'
  4573:     | _ -> clierr sr "[bind_expression'] Dereference non pointer"
  4574:     end
  4575: 
  4576:   | `AST_new (srr,e) ->
  4577:      let e,t as x = be e in
  4578:      `BEXPR_new x, `BTYP_pointer t
  4579: 
  4580:   | `AST_literal (sr,v) ->
  4581:     let t = typeof_literal syms env sr v in
  4582:     `BEXPR_literal v, t
  4583: 
  4584:   | `AST_method_apply (sra,(fn,e2,meth_ts)) ->
  4585:     (*
  4586:     print_endline ("METHOD APPLY: " ^ string_of_expr e);
  4587:     *)
  4588:     (* .. PRAPS .. *)
  4589:     let meth_ts = map (bt sra) meth_ts in
  4590:     let (be2,t2) as x2 = be e2 in
  4591:     begin match t2 with
  4592:     | `BTYP_lvalue(`BTYP_record es)
  4593:     | `BTYP_record es ->
  4594:       let rcmp (s1,_) (s2,_) = compare s1 s2 in
  4595:       let es = sort rcmp es in
  4596:       let field_name = String.sub fn 4 (String.length fn -4) in
  4597:       begin match list_index (map fst es) field_name with
  4598:       | Some n -> `BEXPR_get_n (n,x2),assoc field_name es
  4599:       | None -> clierr sr
  4600:          (
  4601:            "Field " ^ field_name ^
  4602:            " is not a member of anonymous structure " ^
  4603:            sbt syms.dfns t2
  4604:           )
  4605:       end
  4606:     | _ ->
  4607:     let tbe1 =
  4608:       match t2 with
  4609:       | `BTYP_lvalue(`BTYP_inst (index,ts))
  4610:       | `BTYP_inst (index,ts) ->
  4611:         begin match get_data syms.dfns index with
  4612:         {id=id; parent=parent;sr=sr;symdef=entry} ->
  4613:         match parent with
  4614:         | None -> clierr sra "Koenig lookup: No parent for method apply (can't handle global yet)"
  4615:         | Some index' ->
  4616:           match get_data syms.dfns index' with
  4617:           {id=id';sr=sr';parent=parent';vs=vs';pubmap=name_map;dirs=dirs;symdef=entry'}
  4618:           ->
  4619:           match entry' with
  4620:           | `SYMDEF_module
  4621:           | `SYMDEF_function _
  4622:             ->
  4623:             koenig_lookup syms env rs sra id' name_map fn t2 (ts @ meth_ts)
  4624: 
  4625:           | _ -> clierr sra ("Koenig lookup: parent for method apply not module")
  4626:         end
  4627: 
  4628:       | _ -> clierr sra ("apply method "^fn^" to nongenerative type")
  4629:     in
  4630:       cal_apply syms sra tbe1 (be2, t2)
  4631:     end
  4632: 
  4633:   | `AST_map (sr,f,a) ->
  4634:     handle_map sr (be f) (be a)
  4635: 
  4636:   | `AST_apply (sr,(f',a')) ->
  4637:     (*
  4638:     print_endline ("Apply " ^ string_of_expr f' ^ " to " ^  string_of_expr a');
  4639:     print_env env;
  4640:     *)
  4641:     let (ea,ta) as a = be a' in
  4642:     (*
  4643:     print_endline ("Recursive descent into application " ^ string_of_expr e);
  4644:     *)
  4645:     let (bf,tf) as f  =
  4646:       match f' with
  4647:       | #qualified_name_t as name ->
  4648:         let sigs = map snd args in
  4649:         let srn = src_of_expr name in
  4650:         (*
  4651:         print_endline "Lookup qn with sig .. ";
  4652:         *)
  4653:         lookup_qn_with_sig' syms sr srn env
  4654:           { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist }
  4655:           name (ta::sigs)
  4656:       | _ -> bind_expression' syms env rs f' (a :: args)
  4657:     in
  4658:     (*
  4659:     print_endline ("tf=" ^ sbt syms.dfns tf);
  4660:     print_endline ("ta=" ^ sbt syms.dfns ta);
  4661:     *)
  4662:     begin match tf with
  4663:     | `BTYP_cfunction _ -> cal_apply syms sr f a
  4664:     | `BTYP_function _ ->
  4665:       (* print_endline "Function .. cal apply"; *)
  4666:       cal_apply syms sr f a
  4667:     | _ ->
  4668:       let apl name =
  4669:         be
  4670:         (
  4671:           `AST_apply
  4672:           (
  4673:             sr,
  4674:             (
  4675:               `AST_name (sr,name,[]),
  4676:               `AST_tuple (sr,[f';a'])
  4677:             )
  4678:           )
  4679:         )
  4680:       in
  4681:       apl "apply"
  4682:     end
  4683: 
  4684: 
  4685:   | `AST_arrayof (sr,es) ->
  4686:     let bets = map be es in
  4687:     let _, bts = split bets in
  4688:     let n = length bets in
  4689:     if n > 1 then begin
  4690:       let t = hd bts in
  4691:       iter
  4692:       (fun t' -> if t <> t' then
  4693:          clierr sr
  4694:          (
  4695:            "Elements of this array must all be of type:\n" ^
  4696:            sbt syms.dfns t ^ "\ngot:\n"^ sbt syms.dfns t'
  4697:          )
  4698:       )
  4699:       (tl bts)
  4700:       ;
  4701:       let t = `BTYP_array (t,`BTYP_unitsum n) in
  4702:       `BEXPR_tuple bets,t
  4703:     end else if n = 1 then hd bets
  4704:     else syserr sr "Empty array?"
  4705: 
  4706:   | `AST_record_type _ -> assert false
  4707:   | `AST_variant_type _ -> assert false
  4708: 
  4709:   | `AST_record (sr,ls) ->
  4710:     begin match ls with
  4711:     | [] -> `BEXPR_tuple [],`BTYP_tuple []
  4712:     | _ ->
  4713:     let ss,es = split ls in
  4714:     let es = map be es in
  4715:     let ts = map snd es in
  4716:     let t = `BTYP_record (combine ss ts) in
  4717:     `BEXPR_record (combine ss es),t
  4718:     end
  4719: 
  4720:   | `AST_tuple (_,es) ->
  4721:     let bets = map be es in
  4722:     let _, bts = split bets in
  4723:     let n = length bets in
  4724:     if n > 1 then
  4725:       try
  4726:         let t = hd bts in
  4727:         iter
  4728:         (fun t' -> if t <> t' then raise Not_found)
  4729:         (tl bts)
  4730:         ;
  4731:         let t = `BTYP_array (t,`BTYP_unitsum n) in
  4732:         `BEXPR_tuple bets,t
  4733:       with Not_found ->
  4734:         `BEXPR_tuple bets, `BTYP_tuple bts
  4735:     else if n = 1 then
  4736:       hd bets
  4737:     else
  4738:     `BEXPR_tuple [],`BTYP_tuple []
  4739: 
  4740: 
  4741:   (*
  4742:   | `AST_dot (sr,(e,name,ts)) ->
  4743:   *)
  4744:   | `AST_dot (sr,(e,e2)) ->
  4745: 
  4746:     (* Analyse LHS *)
  4747:     let (_,tt') as te = be e in (* polymorphic! *)
  4748:     let is_lvalue = match tt' with
  4749:       | `BTYP_lvalue _ -> true
  4750:       | _ -> false
  4751:     in
  4752:     let lmap t = if is_lvalue then `BTYP_lvalue t else t in
  4753:     let tt' = rt tt' in
  4754: 
  4755: 
  4756:     begin match e2 with
  4757:     | `AST_name (_,name,ts) ->
  4758:       begin match tt' with
  4759:       | `BTYP_inst (i,ts') ->
  4760:         begin match Hashtbl.find syms.dfns i with
  4761:         | {id=id; vs=vs; symdef=`SYMDEF_struct ls } ->
  4762:           let cidx,ct =
  4763:             let rec scan i = function
  4764:             | [] -> failwith "Can't find struct component"
  4765:             | (vn,vat)::_ when vn = name -> i,vat
  4766:             | _:: t -> scan (i+1) t
  4767:             in scan 0 ls
  4768:           in
  4769:           let ct =
  4770:             let bvs = map (fun (n,i,_) -> n,`BTYP_var (i,`BTYP_type 0)) (fst vs) in
  4771:             let env' = build_env syms (Some i) in
  4772:             bind_type' syms env' rsground sr ct bvs mkenv
  4773:           in
  4774:           let vs' = map (fun (s,i,tp) -> s,i) (fst vs) in
  4775:           let ct = tsubst vs' ts' ct in
  4776:           (* propagate lvalueness to struct component *)
  4777:           `BEXPR_get_n (cidx,te),lmap ct
  4778: 
  4779:         | {id=id; vs=vs; symdef=`SYMDEF_cstruct ls } ->
  4780:           (* NOTE: we try $1.name binding using get_n first,
  4781:           but if we can't find a component we treat the
  4782:           entity as abstract.
  4783: 
  4784:           Hmm not sure that cstructs can be polymorphic.
  4785:           *)
  4786:           begin try
  4787:             let cidx,ct =
  4788:               let rec scan i = function
  4789:               | [] -> raise Not_found
  4790:               | (vn,vat)::_ when vn = name -> i,vat
  4791:               | _:: t -> scan (i+1) t
  4792:               in scan 0 ls
  4793:             in
  4794:             let ct =
  4795:               let bvs = map (fun (n,i,_) -> n,`BTYP_var (i,`BTYP_type 0)) (fst vs) in
  4796:               let env' = build_env syms (Some i) in
  4797:               bind_type' syms env' rsground sr ct bvs mkenv
  4798:             in
  4799:             let vs' = map (fun (s,i,tp) -> s,i) (fst vs) in
  4800:             let ct = tsubst vs' ts' ct in
  4801:             (* propagate lvalueness to struct component *)
  4802:             `BEXPR_get_n (cidx,te),lmap ct
  4803:           with
  4804:           | Not_found ->
  4805:             (*
  4806:             print_endline ("Synth get method .. (1) " ^ name);
  4807:             *)
  4808:             let get_name = "get_" ^ name in
  4809:             be (`AST_method_apply (sr,(get_name,e,ts)))
  4810:           end
  4811: 
  4812:         | {id=id; pubmap=pubtab; symdef = `SYMDEF_class } ->
  4813:           (*
  4814:           print_endline "AST_get_named finds a class .. ";
  4815:           print_endline ("Looking for component named " ^ name);
  4816:           *)
  4817:           let entryset =
  4818:             try Hashtbl.find pubtab name
  4819:             with Not_found -> clierr sr ("[lookup: dot] Cannot find component " ^ name ^ " in class")
  4820:           in
  4821:           begin match entryset with
  4822:           | `NonFunctionEntry idx ->
  4823:             let idx = sye idx in
  4824:             let vtype =
  4825:               inner_typeofindex_with_ts syms sr
  4826:               { rs with expr_fixlist = (e,rs.depth)::rs.expr_fixlist; depth = rs.depth+1 }
  4827:               idx ts'
  4828:              in
  4829:              (*
  4830:              print_endline ("Class member variable has type " ^ sbt syms.dfns vtype);
  4831:              *)
  4832:              `BEXPR_get_named (idx,te),vtype
  4833:           | `FunctionEntry _ ->
  4834:             (* WEAK! *)
  4835:             (*
  4836:             print_endline ("Synth get method .. (2) " ^ name);
  4837:             *)
  4838:             let get_name = "get_" ^ name in
  4839:             be (`AST_method_apply (sr,(get_name,e,ts)))
  4840: 
  4841:           end
  4842: 
  4843:         | {id=id; symdef=`SYMDEF_cclass _} ->
  4844:             (*
  4845:             print_endline ("Synth get method .. (3) " ^ name);
  4846:             *)
  4847:           let get_name = "get_" ^ name in
  4848:           be (`AST_method_apply (sr,(get_name,e,ts)))
  4849: 
  4850:         (* abstract type binding *)
  4851:         | {id=id; symdef=`SYMDEF_abs _ } ->
  4852:             (*
  4853:             print_endline ("Synth get method .. (4) " ^ name);
  4854:             *)
  4855:           let get_name = "get_" ^ name in
  4856:           be (`AST_method_apply (sr,(get_name,e,ts)))
  4857: 
  4858:         | _ ->
  4859:           failwith ("operator . Expected nominal type to be"^
  4860:           " struct, cstruct or abstract primitive, got " ^
  4861:           sbt syms.dfns tt')
  4862: 
  4863:         end
  4864: 
  4865:       | `BTYP_record es ->
  4866:         let rcmp (s1,_) (s2,_) = compare s1 s2 in
  4867:         let es = sort rcmp es in
  4868:         let field_name = name in
  4869:         begin match list_index (map fst es) field_name with
  4870:         | Some n -> `BEXPR_get_n (n,te),lmap (assoc field_name es)
  4871:         | None -> clierr sr
  4872:            (
  4873:              "Field " ^ field_name ^
  4874:              " is not a member of anonymous structure type " ^
  4875:              sbt syms.dfns tt'
  4876:             )
  4877:         end
  4878: 
  4879:       | `BTYP_function (d,c) ->
  4880:         failwith ("LHS of operator . has a function type\n"
  4881:         ^ "but RHS is simple name: should overload somehow?")
  4882: 
  4883:       | `BTYP_tuple _ ->
  4884:         failwith ("Expected nominal type! Got tuple ! " ^ sbt syms.dfns tt')
  4885: 
  4886:       | _ -> failwith ("Expected nominal type! Got " ^ sbt syms.dfns tt')
  4887:       end
  4888: 
  4889:     | _ -> failwith "AST_dot, arg not name not handled yet"
  4890:   end
  4891: 
  4892:   | `AST_match_case (sr,(v,e)) ->
  4893:      `BEXPR_match_case (v,be e),flx_bbool
  4894: 
  4895:   | `AST_match_ctor (sr,(qn,e)) ->
  4896:     begin match qn with
  4897:     | `AST_name (sr,name,ts) ->
  4898:       (*
  4899:       print_endline ("WARNING(deprecate): match constructor by name! " ^ name);
  4900:       *)
  4901:       let (_,ut) as ue = be e in
  4902:       let ut = rt ut in
  4903:       (*
  4904:       print_endline ("Union type is " ^ sbt syms.dfns ut);
  4905:       *)
  4906:       begin match ut with
  4907:       | `BTYP_inst (i,ts') ->
  4908:         (*
  4909:         print_endline ("OK got type " ^ si i);
  4910:         *)
  4911:         begin match Hashtbl.find syms.dfns i with
  4912:         | {id=id; symdef=`SYMDEF_union ls } ->
  4913:           (*
  4914:           print_endline ("UNION TYPE! " ^ id);
  4915:           *)
  4916:           let vidx =
  4917:             let rec scan = function
  4918:             | [] -> failwith "Can't find union variant"
  4919:             | (vn,vidx,vs',vat)::_ when vn = name -> vidx
  4920:             | _:: t -> scan t
  4921:             in scan ls
  4922:           in
  4923:           (*
  4924:           print_endline ("Index is " ^ si vidx);
  4925:           *)
  4926:           `BEXPR_match_case (vidx,ue),flx_bbool
  4927: 
  4928:         (* this handles the case of a C type we want to model
  4929:         as a union by provding _match_ctor_name style function
  4930:         as C primitives ..
  4931:         *)
  4932:         | {id=id; symdef=`SYMDEF_abs _ } ->
  4933:           let fname = `AST_name (sr,"_match_ctor_" ^ name,ts) in
  4934:           be (`AST_apply ( sr, (fname,e)))
  4935: 
  4936:         | _ -> clierr sr ("expected union of abstract type, got" ^ sbt syms.dfns ut)
  4937:         end
  4938:       | _ -> clierr sr ("expected nominal type, got" ^ sbt syms.dfns ut)
  4939:       end
  4940: 
  4941:     | `AST_lookup (sr,(context,name,ts)) ->
  4942:       (*
  4943:       print_endline ("WARNING(deprecate): match constructor by name! " ^ name);
  4944:       *)
  4945:       let (_,ut) as ue = be e in
  4946:       let ut = rt ut in
  4947:       (*
  4948:       print_endline ("Union type is " ^ sbt syms.dfns ut);
  4949:       *)
  4950:       begin match ut with
  4951:       | `BTYP_inst (i,ts') ->
  4952:         (*
  4953:         print_endline ("OK got type " ^ si i);
  4954:         *)
  4955:         begin match Hashtbl.find syms.dfns i with
  4956:         | {id=id; symdef=`SYMDEF_union ls } ->
  4957:           (*
  4958:           print_endline ("UNION TYPE! " ^ id);
  4959:           *)
  4960:           let vidx =
  4961:             let rec scan = function
  4962:             | [] -> failwith "Can't find union variant"
  4963:             | (vn,vidx,vs,vat)::_ when vn = name -> vidx
  4964:             | _:: t -> scan t
  4965:             in scan ls
  4966:           in
  4967:           (*
  4968:           print_endline ("Index is " ^ si vidx);
  4969:           *)
  4970:           `BEXPR_match_case (vidx,ue),flx_bbool
  4971: 
  4972:         (* this handles the case of a C type we want to model
  4973:         as a union by provding _match_ctor_name style function
  4974:         as C primitives ..
  4975:         *)
  4976:         | {id=id; symdef=`SYMDEF_abs _ } ->
  4977:           let fname = `AST_lookup (sr,(context,"_match_ctor_" ^ name,ts)) in
  4978:           be (`AST_apply ( sr, (fname,e)))
  4979:         | _ -> failwith "Woooops expected union or abstract type"
  4980:         end
  4981:       | _ -> failwith "Woops, expected nominal type"
  4982:       end
  4983: 
  4984:     | `AST_typed_case (sr,v,_)
  4985:     | `AST_case_tag (sr,v) ->
  4986:        be (`AST_match_case (sr,(v,e)))
  4987: 
  4988:     | _ -> clierr sr "Expected variant constructor name in union decoder"
  4989:     end
  4990: 
  4991:   | `AST_case_arg (sr,(v,e)) ->
  4992:      let (_,t) as e' = be e in
  4993:     ignore (try unfold syms.dfns t with _ -> failwith "AST_case_arg unfold screwd");
  4994:      begin match lstrip syms.dfns (unfold syms.dfns t) with
  4995:      | `BTYP_unitsum n ->
  4996:        if v < 0 or v >= n
  4997:        then clierr sr "Invalid sum index"
  4998:        else
  4999:          `BEXPR_case_arg (v, e'),unit_t
  5000: 
  5001:      | `BTYP_sum ls ->
  5002:        let n = length ls in
  5003:        if v<0 or v>=n
  5004:        then clierr sr "Invalid sum index"
  5005:        else let t = nth ls v in
  5006:        `BEXPR_case_arg (v, e'),t
  5007: 
  5008:      | _ -> clierr sr ("Expected sum type, got " ^ sbt syms.dfns t)
  5009:      end
  5010: 
  5011:   | `AST_ctor_arg (sr,(qn,e)) ->
  5012:     begin match qn with
  5013:     | `AST_name (sr,name,ts) ->
  5014:       (*
  5015:       print_endline ("WARNING(deprecate): decode variant by name! " ^ name);
  5016:       *)
  5017:       let (_,ut) as ue = be e in
  5018:       let ut = rt ut in
  5019:       (*
  5020:       print_endline ("Union type is " ^ sbt syms.dfns ut);
  5021:       *)
  5022:       begin match ut with
  5023:       | `BTYP_inst (i,ts') ->
  5024:         (*
  5025:         print_endline ("OK got type " ^ si i);
  5026:         *)
  5027:         begin match Hashtbl.find syms.dfns i with
  5028:         | {id=id; vs=vs; symdef=`SYMDEF_union ls } ->
  5029:           (*
  5030:           print_endline ("UNION TYPE! " ^ id);
  5031:           *)
  5032:           let vidx,vt =
  5033:             let rec scan = function
  5034:             | [] -> failwith "Can't find union variant"
  5035:             | (vn,vidx,vs',vt)::_ when vn = name -> vidx,vt
  5036:             | _:: t -> scan t
  5037:             in scan ls
  5038:           in
  5039:           (*
  5040:           print_endline ("Index is " ^ si vidx);
  5041:           *)
  5042:           let vt =
  5043:             let bvs = map (fun (n,i,_) -> n,`BTYP_var (i,`BTYP_type 0)) (fst vs) in
  5044:             (*
  5045:             print_endline ("Binding ctor arg type = " ^ string_of_typecode vt);
  5046:             *)
  5047:             let env' = build_env syms (Some i) in
  5048:             bind_type' syms env' rsground sr vt bvs mkenv
  5049:           in
  5050:           (*
  5051:           print_endline ("Bound polymorphic type = " ^ sbt syms.dfns vt);
  5052:           *)
  5053:           let vs' = map (fun (s,i,tp) -> s,i) (fst vs) in
  5054:           let vt = tsubst vs' ts' vt in
  5055:           (*
  5056:           print_endline ("Instantiated type = " ^ sbt syms.dfns vt);
  5057:           *)
  5058:           `BEXPR_case_arg (vidx,ue),vt
  5059: 
  5060:         (* this handles the case of a C type we want to model
  5061:         as a union by provding _ctor_arg style function
  5062:         as C primitives ..
  5063:         *)
  5064:         | {id=id; symdef=`SYMDEF_abs _ } ->
  5065:           let fname = `AST_name (sr,"_ctor_arg_" ^ name,ts) in
  5066:           be (`AST_apply ( sr, (fname,e)))
  5067: 
  5068:         | _ -> failwith "Woooops expected union or abstract type"
  5069:         end
  5070:       | _ -> failwith "Woops, expected nominal type"
  5071:       end
  5072: 
  5073: 
  5074:     | `AST_lookup (sr,(e,name,ts)) ->
  5075:       (*
  5076:       print_endline ("WARNING(deprecate): decode variant by name! " ^ name);
  5077:       *)
  5078:       let (_,ut) as ue = be e in
  5079:       let ut = rt ut in
  5080:       (*
  5081:       print_endline ("Union type is " ^ sbt syms.dfns ut);
  5082:       *)
  5083:       begin match ut with
  5084:       | `BTYP_inst (i,ts') ->
  5085:         (*
  5086:         print_endline ("OK got type " ^ si i);
  5087:         *)
  5088:         begin match Hashtbl.find syms.dfns i with
  5089:         | {id=id; vs=vs; symdef=`SYMDEF_union ls } ->
  5090:           (*
  5091:           print_endline ("UNION TYPE! " ^ id);
  5092:           *)
  5093:           let vidx,vt =
  5094:             let rec scan = function
  5095:             | [] -> failwith "Can't find union variant"
  5096:             | (vn,vidx,vs',vt)::_ when vn = name -> vidx,vt
  5097:             | _:: t -> scan t
  5098:             in scan ls
  5099:           in
  5100:           (*
  5101:           print_endline ("Index is " ^ si vidx);
  5102:           *)
  5103:           let vt =
  5104:             let bvs = map (fun (n,i,_) -> n,`BTYP_var (i,`BTYP_type 0)) (fst vs) in
  5105:             (*
  5106:             print_endline ("Binding ctor arg type = " ^ string_of_typecode vt);
  5107:             *)
  5108:             let env' = build_env syms (Some i) in
  5109:             bind_type' syms env' rsground sr vt bvs mkenv
  5110:           in
  5111:           (*
  5112:           print_endline ("Bound polymorphic type = " ^ sbt syms.dfns vt);
  5113:           *)
  5114:           let vs' = map (fun (s,i,tp) -> s,i) (fst vs) in
  5115:           let vt = tsubst vs' ts' vt in
  5116:           (*
  5117:           print_endline ("Instantiated type = " ^ sbt syms.dfns vt);
  5118:           *)
  5119:           `BEXPR_case_arg (vidx,ue),vt
  5120: 
  5121:         (* this handles the case of a C type we want to model
  5122:         as a union by provding _match_ctor_name style function
  5123:         as C primitives ..
  5124:         *)
  5125:         | {id=id; symdef=`SYMDEF_abs _ } ->
  5126:           let fname = `AST_lookup (sr,(e,"_ctor_arg_" ^ name,ts)) in
  5127:           be (`AST_apply ( sr, (fname,e)))
  5128: 
  5129:         | _ -> failwith "Woooops expected union or abstract type"
  5130:         end
  5131:       | _ -> failwith "Woops, expected nominal type"
  5132:       end
  5133: 
  5134: 
  5135:     | `AST_typed_case (sr,v,_)
  5136:     | `AST_case_tag (sr,v) ->
  5137:       be (`AST_case_arg (sr,(v,e)))
  5138: 
  5139:     | _ -> clierr sr "Expected variant constructor name in union dtor"
  5140:     end
  5141: 
  5142:   | `AST_string_regmatch (sr,_)
  5143:   | `AST_regmatch (sr,_) ->
  5144:     syserr sr
  5145:     (
  5146:       "[bind_expression] "  ^
  5147:       "Unexpected regmatch when binding expression (should have been lifted out)" ^
  5148:       string_of_expr e
  5149:     )
  5150: 
  5151:   | `AST_reglex (sr,(p1,p2,cls)) ->
  5152:     syserr sr
  5153:     (
  5154:       "[bind_expression] " ^
  5155:       "Unexpected reglex when binding expression (should have been lifted out)" ^
  5156:       string_of_expr e
  5157:     )
  5158: 
  5159:   | `AST_lambda (sr,_) ->
  5160:     syserr sr
  5161:     (
  5162:       "[bind_expression] " ^
  5163:       "Unexpected lambda when binding expression (should have been lifted out)" ^
  5164:       string_of_expr e
  5165:     )
  5166: 
  5167:   | `AST_match (sr,_) ->
  5168:     clierr sr
  5169:     (
  5170:       "[bind_expression] " ^
  5171:       "Unexpected match when binding expression (should have been lifted out)"
  5172:     )
  5173: 
  5174: and resolve_overload
  5175:   syms
  5176:   env
  5177:   sr
  5178:   (fs : entry_kind_t list)
  5179:   (name: string)
  5180:   (sufs : btypecode_t list)
  5181:   (ts:btypecode_t list)
  5182: : overload_result option =
  5183:   resolve_overload' syms env rsground sr fs name sufs ts
  5184: 
  5185: 
  5186: and hack_name qn = match qn with
  5187: | `AST_name (sr,name,ts) -> `AST_name (sr,"_inst_"^name,ts)
  5188: | `AST_lookup (sr,(e,name,ts)) -> `AST_lookup (sr,(e,"_inst_"^name,ts))
  5189: | _ -> failwith "expected qn .."
  5190: 
  5191: and grab_ts qn = match qn with
  5192: | `AST_name (sr,name,ts) -> ts
  5193: | `AST_lookup (sr,(e,name,ts)) -> ts
  5194: | _ -> failwith "expected qn .."
  5195: 
  5196: and grab_name qn = match qn with
  5197: | `AST_name (sr,name,ts) -> name
  5198: | `AST_lookup (sr,(e,name,ts)) -> name
  5199: | _ -> failwith "expected qn .."
  5200: 
  5201: 
  5202: and check_instances syms call_sr calledname classname es ts' mkenv =
  5203:   let insts = ref [] in
  5204:   match es with
  5205:   | `NonFunctionEntry _ -> print_endline "EXPECTED INSTANCES TO BE FUNCTION SET"
  5206:   | `FunctionEntry es ->
  5207:     (*
  5208:     print_endline ("instance Candidates " ^ catmap "," string_of_entry_kind es);
  5209:     *)
  5210:     iter
  5211:     (fun {base_sym=i; spec_vs=spec_vs; sub_ts=sub_ts} ->
  5212:     match Hashtbl.find syms.dfns i  with
  5213:     {id=id;sr=sr;parent=parent;vs=vs;symdef=entry} ->
  5214:     match entry with
  5215:     | `SYMDEF_instance qn' ->
  5216:       (*
  5217:       print_endline ("Verified " ^ si i ^ " is an instance of " ^ id);
  5218:       print_endline ("  base vs = " ^ print_ivs_with_index vs);
  5219:       print_endline ("  spec vs = " ^ catmap "," (fun (s,i) -> s^"<"^si i^">") spec_vs);
  5220:       print_endline ("  view ts = " ^ catmap "," (fun t -> sbt syms.dfns t) sub_ts);
  5221:       *)
  5222:       let inst_ts = grab_ts qn' in
  5223:       (*
  5224:       print_endline ("Unbound instance ts = " ^ catmap "," string_of_typecode inst_ts);
  5225:       *)
  5226:       let instance_env = mkenv i in
  5227:       let bt t = bind_type' syms instance_env rsground sr t [] mkenv in
  5228:       let inst_ts = map bt inst_ts in
  5229:       (*
  5230:       print_endline ("  instance ts = " ^ catmap "," (fun t -> sbt syms.dfns t) inst_ts);
  5231:       print_endline ("  caller   ts = " ^ catmap "," (fun t -> sbt syms.dfns t) ts');
  5232:       *)
  5233:       let matches =
  5234:         if length inst_ts <> length ts' then false else
  5235:         match maybe_specialisation syms.dfns (combine inst_ts ts') with
  5236:         | None -> false
  5237:         | Some mgu ->
  5238:           (*
  5239:           print_endline ("MGU: " ^ catmap ", " (fun (i,t)-> si i ^ "->" ^ sbt syms.dfns t) mgu);
  5240:           print_endline ("check base vs (constraint) = " ^ print_ivs_with_index vs);
  5241:           *)
  5242:           let cons = try
  5243:             Flx_tconstraint.build_type_constraints syms bt sr (fst vs)
  5244:             with _ -> clierr sr "Can't build type constraints, type binding failed"
  5245:           in
  5246:           let {raw_type_constraint=icons} = snd vs in
  5247:           let icons = bt icons in
  5248:           (*
  5249:           print_endline ("Constraint = " ^ sbt syms.dfns cons);
  5250:           print_endline ("VS Constraint = " ^ sbt syms.dfns icons);
  5251:           *)
  5252:           let cons = `BTYP_intersect [cons; icons] in
  5253:           (*
  5254:           print_endline ("Constraint = " ^ sbt syms.dfns cons);
  5255:           *)
  5256:           let cons = list_subst mgu cons in
  5257:           (*
  5258:           print_endline ("Constraint = " ^ sbt syms.dfns cons);
  5259:           *)
  5260:           let cons = Flx_maps.reduce_type (beta_reduce syms sr cons) in
  5261:           match cons with
  5262:           | `BTYP_tuple [] -> true
  5263:           | `BTYP_void -> false
  5264:           | _ ->
  5265:              (*
  5266:               print_endline (
  5267:                "[instance_check] Can't reduce instance type constraint " ^
  5268:                sbt syms.dfns cons
  5269:              );
  5270:              *)
  5271:              true
  5272:       in
  5273: 
  5274:       if matches then begin
  5275:         (*
  5276:         print_endline "INSTANCE MATCHES";
  5277:         *)
  5278:         insts := `Inst i :: !insts
  5279:       end
  5280:       (*
  5281:       else
  5282:         print_endline "INSTANCE DOES NOT MATCH: REJECTED"
  5283:       *)
  5284:       ;
  5285: 
  5286: 
  5287:     | `SYMDEF_typeclass ->
  5288:       (*
  5289:       print_endline ("Verified " ^ si i ^ " is an typeclass specialisation of " ^ classname);
  5290:       print_endline ("  base vs = " ^ print_ivs_with_index vs);
  5291:       print_endline ("  spec vs = " ^ catmap "," (fun (s,i) -> s^"<"^si i^">") spec_vs);
  5292:       print_endline ("  view ts = " ^ catmap "," (fun t -> sbt syms.dfns t) sub_ts);
  5293:       *)
  5294:       if sub_ts = ts' then begin
  5295:         (*
  5296:         print_endline "SPECIALISATION MATCHES";
  5297:         *)
  5298:         insts := `Typeclass (i,sub_ts) :: !insts
  5299:       end
  5300:       (*
  5301:       else
  5302:         print_endline "SPECIALISATION DOES NOT MATCH: REJECTED"
  5303:       ;
  5304:       *)
  5305: 
  5306:     | _ -> print_endline "EXPECTED TYPECLASS INSTANCE!"
  5307:     )
  5308:     es
  5309:     ;
  5310:     (*
  5311:     begin match !insts with
  5312:     | [`Inst i] -> ()
  5313:     | [`Typeclass (i,ts)] -> ()
  5314:     | [] ->
  5315:       print_endline ("WARNING: In call of " ^ calledname ^", Typeclass instance matching " ^
  5316:         classname ^"["^catmap "," (sbt syms.dfns) ts' ^"]" ^
  5317:         " not found"
  5318:       )
  5319:     | `Inst i :: t ->
  5320:       print_endline ("WARNING: In call of " ^ calledname ^", More than one instances matching " ^
  5321:         classname ^"["^catmap "," (sbt syms.dfns) ts' ^"]" ^
  5322:         " found"
  5323:       );
  5324:       print_endline ("Call of " ^ calledname ^ " at " ^ short_string_of_src call_sr);
  5325:       iter (fun i ->
  5326:         match i with
  5327:         | `Inst i -> print_endline ("Instance " ^ si i)
  5328:         | `Typeclass (i,ts) -> print_endline ("Typeclass " ^ si i^"[" ^ catmap "," (sbt syms.dfns) ts ^ "]")
  5329:       )
  5330:       !insts
  5331: 
  5332:     | `Typeclass (i,ts) :: tail ->
  5333:       clierr call_sr ("In call of " ^ calledname ^", Multiple typeclass specialisations matching " ^
  5334:         classname ^"["^catmap "," (sbt syms.dfns) ts' ^"]" ^
  5335:         " found"
  5336:       )
  5337:     end
  5338:     *)
  5339: 
  5340: 
  5341: and instance_check syms caller_env called_env mgu sr calledname rtcr tsub =
  5342:   (*
  5343:   print_endline ("INSTANCE CHECK MGU: " ^ catmap ", " (fun (i,t)-> si i ^ "->" ^ sbt syms.dfns t) mgu);
  5344:   print_endline "SEARCH FOR INSTANCE!";
  5345:   print_env caller_env;
  5346:   *)
  5347:   let luqn2 qn = lookup_qn_in_env2 syms caller_env qn in
  5348:   if length rtcr > 0 then begin
  5349:     (*
  5350:     print_endline (calledname ^" TYPECLASS INSTANCES REQUIRED (unbound): " ^
  5351:       catmap "," string_of_qualified_name rtcr
  5352:     );
  5353:     *)
  5354:     iter
  5355:     (fun qn ->
  5356:       let call_sr = src_of_expr (qn:>expr_t) in
  5357:       let classname = grab_name qn in
  5358:       let es,ts' =
  5359:         try luqn2 (hack_name qn)
  5360:         with
  5361:           (* This is a HACK. we need lookup to throw a specific
  5362:              lookup failure exception
  5363:           *)
  5364:           ClientError (sr',msg) -> raise (ClientError2 (sr,sr',msg))
  5365:       in
  5366:       (*
  5367:       print_endline ("With unbound ts = " ^ catmap "," string_of_typecode ts');
  5368:       *)
  5369:       let ts' = map (fun t -> try bind_type syms called_env sr t with _ -> print_endline "Bind type failed .."; assert false) ts' in
  5370:       (*
  5371:       print_endline ("With bound ts = " ^ catmap "," (sbt syms.dfns) ts');
  5372:       *)
  5373:       let ts' = map tsub ts' in
  5374:       (*
  5375:       print_endline ("With bound, mapped ts = " ^ catmap "," (sbt syms.dfns) ts');
  5376:       *)
  5377:       check_instances syms call_sr calledname classname es ts' (fun i->build_env syms (Some i))
  5378:     )
  5379:     rtcr
  5380:   end
  5381: 
  5382: and resolve_overload'
  5383:   syms
  5384:   caller_env
  5385:   (rs:recstop)
  5386:   sr
  5387:   (fs : entry_kind_t list)
  5388:   (name: string)
  5389:   (sufs : btypecode_t list)
  5390:   (ts:btypecode_t list)
  5391: : overload_result option =
  5392:   if length fs = 0 then None else
  5393:   let env i =
  5394:     (*
  5395:     print_endline ("resolve_overload': Building env for " ^ name ^ "<" ^ si i ^ ">");
  5396:     *)
  5397:     inner_build_env syms rs (Some i)
  5398:   in
  5399:   let bt sr i t =
  5400:     bind_type syms (env i) sr t
  5401:   in
  5402:   let luqn2 i qn = lookup_qn_in_env2 syms (env i) qn in
  5403:   let fs = trclose syms rs sr fs in
  5404:   let result : overload_result option = overload syms bt luqn2 sr fs name sufs ts in
  5405:   begin match result with
  5406:   | None -> ()
  5407:   | Some (index,sign,ret,mgu,ts) ->
  5408:     (*
  5409:     print_endline ("RESOLVED OVERLOAD OF " ^ name);
  5410:     print_endline (" .. mgu = " ^ string_of_varlist syms.dfns mgu);
  5411:     print_endline ("Resolve ts = " ^ catmap "," (sbt syms.dfns) ts);
  5412:     *)
  5413:     let parent_vs,vs,{raw_typeclass_reqs=rtcr} = find_split_vs syms index in
  5414:     (*
  5415:     print_endline ("Function vs=" ^ catmap "," (fun (s,i,_) -> s^"<"^si i^">") vs);
  5416:     print_endline ("Parent vs=" ^ catmap "," (fun (s,i,_) -> s^"<"^si i^">") parent_vs);
  5417:     *)
  5418:     let vs = map (fun (s,i,_)->s,i) (parent_vs @ vs) in
  5419:     let tsub t = tsubst vs ts t in
  5420:     instance_check syms caller_env (env index) mgu sr name rtcr tsub
  5421:   end
  5422:   ;
  5423:   result
  5424: 
  5425: (* an environment is a list of hastables, mapping
  5426:    names to definition indicies. Each entity defining
  5427:    a scope contains one hashtable, and a pointer to
  5428:    its parent, if any. The name 'root' is special,
  5429:    it is the name of the single top level module
  5430:    created by the desugaring phase. We have to be
  5431:    able to find this name, so if when we run out
  5432:    of parents, which is when we hit the top module,
  5433:    we create a parent name map with a single entry
  5434:    'top'->`NonFunctionEntry 0.
  5435: *)
  5436: 
  5437: and split_dirs open_excludes dirs :
  5438:     (ivs_list_t * qualified_name_t) list *
  5439:     (ivs_list_t * qualified_name_t) list *
  5440:     (string * qualified_name_t) list
  5441: =
  5442:   let opens =
  5443:      concat
  5444:      (
  5445:        map
  5446:        (fun x -> match x with
  5447:          | DIR_open (vs,qn) -> if mem (vs,qn) open_excludes then [] else [vs,qn]
  5448:          | DIR_inject_module qn -> []
  5449:          | DIR_use (n,qn) -> []
  5450:        )
  5451:        dirs
  5452:      )
  5453:   and includes =
  5454:      concat
  5455:      (
  5456:        map
  5457:        (fun x -> match x with
  5458:          | DIR_open _-> []
  5459:          | DIR_inject_module qn -> [dfltvs,qn]
  5460:          | DIR_use (n,qn) -> []
  5461:        )
  5462:        dirs
  5463:      )
  5464:   and uses =
  5465:      concat
  5466:      (
  5467:        map
  5468:        (fun x -> match x with
  5469:          | DIR_open _-> []
  5470:          | DIR_inject_module qn -> []
  5471:          | DIR_use (n,qn) -> [n,qn]
  5472:        )
  5473:        dirs
  5474:      )
  5475:   in opens, includes, uses
  5476: 
  5477: (* calculate the transitive closure of an i,ts list
  5478:   with respect to inherit clauses.
  5479: 
  5480:   The result is an i,ts list.
  5481: 
  5482:   This is BUGGED because it ignores typeclass requirements ..
  5483:   however
  5484:   (a) modules can't have them (use inherit clause)
  5485:   (b) typeclasses don't use them (use inherit clause)
  5486:   (c) the routine is only called for modules and typeclasses?
  5487: *)
  5488: 
  5489: and get_includes syms xs =
  5490:   let rec get_includes' syms includes ((invs,i, ts) as index) =
  5491:     if not (mem index !includes) then
  5492:     begin
  5493:       (*
  5494:       if length ts != 0 then
  5495:         print_endline ("INCLUDES, ts="^catmap "," (sbt syms.dfns) ts)
  5496:       ;
  5497:       *)
  5498:       includes := index :: !includes;
  5499:       let env = mk_bare_env syms i in (* should have ts in .. *)
  5500:       let qns,sr,vs =
  5501:         match Hashtbl.find syms.dfns i with
  5502:         {id=id;sr=sr;parent=parent;vs=vs;pubmap=table;dirs=dirs} ->
  5503:         (*
  5504:         print_endline (id ^", Raw vs = " ^ catmap "," (fun (n,k,_) -> n ^ "<" ^ si k ^ ">") (fst vs));
  5505:         *)
  5506:         let _,incl_qns,_ = split_dirs [] dirs in
  5507:         let vs = map (fun (n,i,_) -> n,i) (fst vs) in
  5508:         incl_qns,sr,vs
  5509:       in
  5510:       iter (fun (_,qn) ->
  5511:           let {base_sym=j; spec_vs=vs'; sub_ts=ts'},ts'' =
  5512:             try lookup_qn_in_env syms env qn
  5513:             with Not_found -> failwith "QN NOT FOUND"
  5514:           in
  5515:             let ts'' = map (bind_type syms env sr) ts'' in
  5516:             (*
  5517:             print_endline ("inherit " ^ string_of_qualified_name qn ^
  5518:             ", bound ts="^catmap "," (sbt syms.dfns) ts'');
  5519:             print_endline ("Spec vs = " ^ catmap "," (fun (n,k) -> n ^ "<" ^ si k ^ ">") vs');
  5520:             *)
  5521: 
  5522:             let ts'' = map (tsubst vs ts) ts'' in
  5523:             (*
  5524:             print_endline ("Inherit after subs(1): " ^ si j ^ "["^catmap "," (sbt syms.dfns) ts'' ^"]");
  5525:             *)
  5526:             let ts' = map (tsubst vs' ts'') ts' in
  5527:             (*
  5528:             print_endline ("Inherit after subs(2): " ^ si j ^ "["^catmap "," (sbt syms.dfns) ts' ^"]");
  5529:             *)
  5530:             get_includes' syms includes (invs,j,ts')
  5531:       )
  5532:       qns
  5533:     end
  5534:   in
  5535:   let includes = ref [] in
  5536:   iter (get_includes' syms includes) xs;
  5537: 
  5538:   (* list is unique due to check during construction *)
  5539:   !includes
  5540: 
  5541: and bind_dir
  5542:   syms
  5543:   (env:env_t) rs
  5544:   (vs,qn)
  5545: : ivs_list_t * int * btypecode_t list =
  5546:   let sr = ("dummy",0,0,0,0) in
  5547:   (*
  5548:   print_endline ("Try to bind dir " ^ string_of_qualified_name qn);
  5549:   *)
  5550:   let nullmap=Hashtbl.create 3 in
  5551:   (* cheating stuff to add the type variables to the environment *)
  5552:   let cheat_table = Hashtbl.create 7 in
  5553:   iter
  5554:   (fun (n,i,_) ->
  5555:    let entry = `NonFunctionEntry {base_sym=i; spec_vs=[]; sub_ts=[]} in
  5556:     Hashtbl.add cheat_table n entry;
  5557:     if not (Hashtbl.mem syms.dfns i) then
  5558:       Hashtbl.add syms.dfns i {id=n;sr=sr;parent=None;vs=dfltvs;
  5559:       pubmap=nullmap; privmap=nullmap;dirs=[];
  5560:       symdef=`SYMDEF_typevar `TYP_type
  5561:       }
  5562:     ;
  5563:   )
  5564:   (fst vs)
  5565:   ;
  5566:   let cheat_env = (0,"cheat",cheat_table,[]) in
  5567:   let result =
  5568:     try
  5569:       lookup_qn_in_env' syms env
  5570:       {rs with open_excludes = (vs,qn)::rs.open_excludes }
  5571:       qn
  5572:     with Not_found -> failwith "QN NOT FOUND"
  5573:   in
  5574:   match result with
  5575:   | {base_sym=i; spec_vs=spec_vs; sub_ts=ts},ts' ->
  5576:    (* the vs is crap I think .. *)
  5577:    (*
  5578:    the ts' are part of the name and are bound in calling context
  5579:    the ts, if present, are part of a view we found if we
  5580:    happened to open a view, rather than a base module.
  5581:    At present this cannot happen because there is no way
  5582:    to actually name a view.
  5583:    *)
  5584:    (*
  5585:    assert (length vs = 0);
  5586:    assert (length ts = 0);
  5587:    *)
  5588:    let mkenv i = mk_bare_env syms i in
  5589:    let ts' = map (fun t -> beta_reduce syms sr (bind_type' syms (cheat_env::env) rsground sr t [] mkenv)) ts' in
  5590:    (*
  5591:    let ts' = map (fun t-> bind_type syms env sr t) ts' in
  5592:    *)
  5593:    vs,i,ts'
  5594: 
  5595: and review_entry syms vs ts {base_sym=i; spec_vs=vs'; sub_ts=ts'} : entry_kind_t =
  5596:    (* vs is the set of type variables at the call point,
  5597:      there are vs in the given ts,
  5598:      ts is the instantiation of another view,
  5599:      the number of these should agree with the view variables vs',
  5600:      we're going to plug these into formula got thru that view
  5601:      to form the next one.
  5602:      ts' may contain type variables of vs'.
  5603:      The ts' are ready to plug into the base objects type variables
  5604:      and should agree in number.
  5605: 
  5606:      SO .. we have to replace the vs' in each ts' using the given
  5607:      ts, and then record that the result contains vs variables
  5608:      to allow for the next composition .. whew!
  5609:    *)
  5610: 
  5611:    (* if vs' is has extra variables,
  5612:       (*
  5613:       tack them on to the ts
  5614:       *)
  5615:       synthesise a new vs/ts pair
  5616:       if vs' doesn't have enough variables, just drop the extra ts
  5617:    *)
  5618:     (*
  5619:     print_endline ("input vs="^catmap "," (fun (s,i)->s^"<"^si i^">") vs^
  5620:       ", input ts="^catmap "," (sbt syms.dfns) ts);
  5621:     print_endline ("old vs="^catmap "," (fun (s,i)->s^"<"^si i^">") vs'^
  5622:       ", old ts="^catmap "," (sbt syms.dfns) ts');
  5623:    *)
  5624:    let vs = ref (rev vs) in
  5625:    let vs',ts =
  5626:      let rec aux invs ints outvs outts =
  5627:        match invs,ints with
  5628:        | h::t,h'::t' -> aux t t' (h::outvs) (h'::outts)
  5629:        | h::t,[] ->
  5630:          let i = !(syms.counter) in incr syms.counter;
  5631:          let (name,_) = h in
  5632:          vs := (name,i)::!vs;
  5633:          (*
  5634:          print_endline ("SYNTHESISE FRESH VIEW VARIABLE "^si i^" for missing ts");
  5635:          *)
  5636:          let h' = `BTYP_var (i,`BTYP_type 0) in
  5637:          (*
  5638:          let h' = let (_,i) = h in `BTYP_var (i,`BTYP_type 0) in
  5639:          *)
  5640:          aux t [] (h::outvs) (h'::outts)
  5641:        | _ -> rev outvs, rev outts
  5642:      in aux vs' ts [] []
  5643:    in
  5644:    let vs = rev !vs in
  5645:    let ts' = map (tsubst vs' ts) ts' in
  5646:    {base_sym=i; spec_vs=vs; sub_ts=ts'}
  5647: 
  5648: and review_entry_set syms v vs ts : entry_set_t = match v with
  5649:   | `NonFunctionEntry i -> `NonFunctionEntry (review_entry syms vs ts i)
  5650:   | `FunctionEntry fs -> `FunctionEntry (map (review_entry syms vs ts) fs)
  5651: 
  5652: and make_view_table syms table (vs: (string * int) list) ts : name_map_t =
  5653:   (*
  5654:   print_endline ("vs="^catmap "," (fun (s,_)->s) vs^", ts="^catmap "," (sbt syms.dfns) ts);
  5655:   print_endline "Building view table!";
  5656:   *)
  5657:   let h = Hashtbl.create 97 in
  5658:   Hashtbl.iter
  5659:   (fun k v ->
  5660:     (*
  5661:     print_endline ("Entry " ^ k);
  5662:     *)
  5663:     let v = review_entry_set syms v vs ts in
  5664:     Hashtbl.add h k v
  5665:   )
  5666:   table
  5667:   ;
  5668:   h
  5669: 
  5670: and pub_table_dir
  5671:   syms env inst_check
  5672:   (invs,i,ts)
  5673: : name_map_t =
  5674:   let invs = map (fun (i,n,_)->i,n) (fst invs) in
  5675:   match get_data syms.dfns i with
  5676:   | {id=id; vs=vs; sr=sr; pubmap=table;symdef=`SYMDEF_module} ->
  5677:     if length ts = 0 then table else
  5678:     begin
  5679:       (*
  5680:       print_endline ("TABLE " ^ id);
  5681:       *)
  5682:       let table = make_view_table syms table invs ts in
  5683:       (*
  5684:       print_name_table syms.dfns table;
  5685:       *)
  5686:       table
  5687:     end
  5688: 
  5689:   | {id=id; vs=vs; sr=sr; pubmap=table;symdef=`SYMDEF_typeclass} ->
  5690:     let table = make_view_table syms table [] ts in
  5691:     (* a bit hacky .. add the type class specialisation view
  5692:        to its contents as an instance
  5693:     *)
  5694:     let inst = mkentry syms vs i in
  5695:     let inst = review_entry syms invs ts inst in
  5696:     let inst_name = "_inst_" ^ id in
  5697:     Hashtbl.add table inst_name (`FunctionEntry [inst]);
  5698:     if inst_check then
  5699:     begin
  5700:       if syms.compiler_options.print_flag then
  5701:       print_endline ("Added typeclass "^si i^
  5702:         " as instance " ^ inst_name ^": "^ string_of_myentry syms.dfns inst
  5703:       );
  5704:       let luqn2 qn =
  5705:         try
  5706:           Some (lookup_qn_in_env2 syms env qn)
  5707:         with _ -> None
  5708:       in
  5709:       let res = luqn2 (`AST_name (sr,inst_name,[])) in
  5710:       match res with
  5711:       | None -> clierr sr
  5712:         ("Couldn't find any instances to open for " ^ id ^
  5713:           "[" ^ catmap "," (sbt syms.dfns) ts ^ "]"
  5714:         )
  5715:       | Some (es,_) -> check_instances syms sr "open" id es ts (mk_bare_env syms)
  5716:     end
  5717:     ;
  5718:     table
  5719: 
  5720:   | {sr=sr} -> clierr sr "[map_dir] Expected module"
  5721: 
  5722: 
  5723: and get_pub_tables syms env rs dirs =
  5724:   let _,includes,_ = split_dirs rs.open_excludes dirs in
  5725:   let xs = uniq_list (map (bind_dir syms env rs) includes) in
  5726:   let includes = get_includes syms xs in
  5727:   let tables = map (pub_table_dir syms env false) includes in
  5728:   tables
  5729: 
  5730: and mk_bare_env syms index =
  5731:   match Hashtbl.find syms.dfns index with
  5732:   {id=id;parent=parent;privmap=table} -> (index,id,table,[]) ::
  5733:   match parent with
  5734:   | None -> []
  5735:   | Some index -> mk_bare_env syms index
  5736: 
  5737: and merge_directives syms rs env dirs typeclasses =
  5738:   let env = ref env in
  5739:   let add table =
  5740:    env :=
  5741:      match !env with
  5742:      | (idx, id, nm, nms) :: tail ->
  5743:      (idx, id, nm,  table :: nms) :: tail
  5744:      | [] -> assert false
  5745:   in
  5746:   let use_map = Hashtbl.create 97 in
  5747:   add use_map;
  5748: 
  5749:   let add_qn (vs, qn) =
  5750:     if mem (vs,qn) rs.open_excludes then () else
  5751:     let u = [bind_dir syms !env rs (vs,qn)] in
  5752:     let u = get_includes syms u in
  5753:     let tables = map (pub_table_dir syms !env false) u in
  5754:     iter add tables
  5755:   in
  5756:   iter
  5757:   (fun dir -> match dir with
  5758:   | DIR_inject_module qn -> add_qn (dfltvs,qn)
  5759:   | DIR_use (n,qn) ->
  5760:     begin let entry,_ = lookup_qn_in_env2' syms !env rs qn in
  5761:     match entry with
  5762: 
  5763:     | `NonFunctionEntry _ ->
  5764:       if Hashtbl.mem use_map n
  5765:       then failwith "Duplicate non function used"
  5766:       else Hashtbl.add use_map n entry
  5767: 
  5768:     | `FunctionEntry ls ->
  5769:       let entry2 =
  5770:         try Hashtbl.find use_map  n
  5771:         with Not_found -> `FunctionEntry []
  5772:       in
  5773:       match entry2 with
  5774:       | `NonFunctionEntry _ ->
  5775:         failwith "Use function and non-function kinds"
  5776:       | `FunctionEntry ls2 ->
  5777:         Hashtbl.replace use_map n (`FunctionEntry (ls @ ls2))
  5778:     end
  5779: 
  5780:   | DIR_open (vs,qn) -> add_qn (vs,qn)
  5781:  )
  5782:  dirs;
  5783: 
  5784:  (* these should probably be done first not last, because this is
  5785:  the stuff passed through the function interface .. the other
  5786:  opens are merely in the body .. but typeclasses can't contain
  5787:  modules or types at the moment .. only functions .. so it
  5788:  probably doesn't matter
  5789:  *)
  5790:  iter add_qn typeclasses;
  5791:  !env
  5792: 
  5793: and merge_opens syms env rs (typeclasses,opens,includes,uses) =
  5794:   (*
  5795:   print_endline ("MERGE OPENS ");
  5796:   *)
  5797:   let use_map = Hashtbl.create 97 in
  5798:   iter
  5799:   (fun (n,qn) ->
  5800:     let entry,_ = lookup_qn_in_env2' syms env rs qn in
  5801:     match entry with
  5802: 
  5803:     | `NonFunctionEntry _ ->
  5804:       if Hashtbl.mem use_map n
  5805:       then failwith "Duplicate non function used"
  5806:       else Hashtbl.add use_map n entry
  5807: 
  5808:     | `FunctionEntry ls ->
  5809:       let entry2 =
  5810:         try Hashtbl.find use_map  n
  5811:         with Not_found -> `FunctionEntry []
  5812:       in
  5813:       match entry2 with
  5814:       | `NonFunctionEntry _ ->
  5815:         failwith "Use function and non-function kinds"
  5816:       | `FunctionEntry ls2 ->
  5817:         Hashtbl.replace use_map n (`FunctionEntry (ls @ ls2))
  5818:   )
  5819:   uses
  5820:   ;
  5821: 
  5822:   (* convert qualified names to i,ts format *)
  5823:   let btypeclasses = map (bind_dir syms env rs) typeclasses in
  5824:   let bopens = map (bind_dir syms env rs) opens in
  5825: 
  5826:   (* HERE! *)
  5827: 
  5828:   let bincludes= map (bind_dir syms env rs) includes in
  5829: 
  5830:   (*
  5831:   (* HACK to check open typeclass *)
  5832:   let _ =
  5833:     let xs = get_includes syms bopens in
  5834:     let tables = map (pub_table_dir syms env true) xs in
  5835:     ()
  5836:   in
  5837:   *)
  5838:   (* strip duplicates *)
  5839:   let u = uniq_cat [] btypeclasses in
  5840:   let u = uniq_cat u bopens in
  5841:   let u = uniq_cat u bincludes in
  5842: 
  5843:   (* add on any inherited modules *)
  5844:   let u = get_includes syms u in
  5845: 
  5846:   (* convert the i,ts list to a list of lookup tables *)
  5847:   let tables = map (pub_table_dir syms env false) u in
  5848: 
  5849:   (* return the list with the explicitly renamed symbols prefixed
  5850:      so they can be used for clash resolution
  5851:   *)
  5852:   use_map::tables
  5853: 
  5854: and build_env'' syms rs index : env_t =
  5855:   match Hashtbl.find syms.dfns index with
  5856:   {id=id; parent=parent; vs=vs; privmap=table;dirs=dirs} ->
  5857:   let typeclasses = match vs with (_,{raw_typeclass_reqs=rtcr})-> rtcr in
  5858:   let env = inner_build_env syms rs parent in
  5859: 
  5860:   (* build temporary bare innermost environment with a full parent env *)
  5861:   let env' = (index,id,table,[])::env in
  5862: 
  5863:   (* use that env to process directives and type classes *)
  5864:   let typeclasses = map (fun qn -> dfltvs,qn) typeclasses in
  5865:   let env = merge_directives syms rs env' dirs typeclasses in
  5866:   env
  5867: 
  5868: and inner_build_env syms rs parent : env_t =
  5869:   match parent with
  5870:   | None -> []
  5871:   | Some i ->
  5872:     try
  5873:       let env = Hashtbl.find syms.env_cache i in
  5874:       env
  5875:     with
  5876:       Not_found ->
  5877:        let env = build_env'' syms rs i in
  5878:        Hashtbl.add syms.env_cache i env;
  5879:        env
  5880: 
  5881: and build_env syms parent : env_t =
  5882:   (*
  5883:   print_endline ("Build env " ^ match parent with None -> "None" | Some i -> si i);
  5884:   *)
  5885:   inner_build_env syms rsground parent
  5886: 
  5887: 
  5888: (*===========================================================*)
  5889: (* MODULE STUFF *)
  5890: (*===========================================================*)
  5891: 
  5892: (* This routine takes a bound type, and produces a unique form
  5893:    of the bound type, by again factoring out type aliases.
  5894:    The type aliases can get reintroduced by map_type,
  5895:    if an abstract type is mapped to a typedef, so we have
  5896:    to factor them out again .. YUK!!
  5897: *)
  5898: 
  5899: and rebind_btype syms env sr ts t: btypecode_t =
  5900:   let rbt t = rebind_btype syms env sr ts t in
  5901:   match t with
  5902:   | `BTYP_inst (i,_) ->
  5903:     begin match get_data syms.dfns i with
  5904:     | {symdef=`SYMDEF_type_alias t'} ->
  5905:       bind_type syms env sr t'
  5906:     | _ -> t
  5907:     end
  5908: 
  5909:   | `BTYP_typesetunion ts -> `BTYP_typesetunion (map rbt ts)
  5910:   | `BTYP_typesetintersection ts -> `BTYP_typesetintersection (map rbt ts)
  5911: 
  5912:   | `BTYP_tuple ts -> `BTYP_tuple (map rbt ts)
  5913:   | `BTYP_record ts ->
  5914:       let ss,ts = split ts in
  5915:       `BTYP_record (combine ss (map rbt ts))
  5916: 
  5917:   | `BTYP_variant ts ->
  5918:       let ss,ts = split ts in
  5919:       `BTYP_variant (combine ss (map rbt ts))
  5920: 
  5921:   | `BTYP_typeset ts ->  `BTYP_typeset (map rbt ts)
  5922:   | `BTYP_intersect ts ->  `BTYP_intersect (map rbt ts)
  5923: 
  5924:   | `BTYP_sum ts ->
  5925:     let ts = map rbt ts in
  5926:     if all_units ts then
  5927:       `BTYP_unitsum (length ts)
  5928:     else
  5929:       `BTYP_sum ts
  5930: 
  5931:   | `BTYP_function (a,r) -> `BTYP_function (rbt a, rbt r)
  5932:   | `BTYP_cfunction (a,r) -> `BTYP_cfunction (rbt a, rbt r)
  5933:   | `BTYP_pointer t -> `BTYP_pointer (rbt t)
  5934:   | `BTYP_lift t -> `BTYP_lift (rbt t)
  5935:   | `BTYP_lvalue t -> lvalify (rbt t)
  5936:   | `BTYP_array (t1,t2) -> `BTYP_array (rbt t1, rbt t2)
  5937: 
  5938:   | `BTYP_unitsum _
  5939:   | `BTYP_void
  5940:   | `BTYP_fix _ -> t
  5941: 
  5942:   | `BTYP_var (i,mt) -> clierr sr ("[rebind_type] Unexpected type variable " ^ sbt syms.dfns t)
  5943:   | `BTYP_case _
  5944:   | `BTYP_apply _
  5945:   | `BTYP_typefun _
  5946:   | `BTYP_type _
  5947:   | `BTYP_type_tuple _
  5948:   | `BTYP_type_match _
  5949:     -> clierr sr ("[rebind_type] Unexpected metatype " ^ sbt syms.dfns t)
  5950: 
  5951: 
  5952: and check_module syms name sr entries ts =
  5953:     begin match entries with
  5954:     | `NonFunctionEntry (index) ->
  5955:       begin match get_data syms.dfns (sye index) with
  5956:       | {dirs=dirs;pubmap=table;symdef=`SYMDEF_module} ->
  5957:         Simple_module (sye index,ts,table,dirs)
  5958:       | {id=id;sr=sr'} ->
  5959:         clierr sr
  5960:         (
  5961:           "Expected '" ^ id ^ "' to be module in: " ^
  5962:           short_string_of_src sr ^ ", found: " ^
  5963:           short_string_of_src sr'
  5964:         )
  5965:       end
  5966:     | _ ->
  5967:       failwith
  5968:       (
  5969:         "Expected non function entry for " ^ name
  5970:       )
  5971:     end
  5972: 
  5973: (* the top level table only has a single entry,
  5974:   the root module, which is the whole file
  5975: 
  5976:   returns the root name, table index, and environment
  5977: *)
  5978: 
  5979: and eval_module_expr syms env e : module_rep_t =
  5980:   (*
  5981:   print_endline ("Eval module expr " ^ string_of_expr e);
  5982:   *)
  5983:   match e with
  5984:   | `AST_name (sr,name,ts) ->
  5985:     let entries = inner_lookup_name_in_env syms env rsground sr name in
  5986:     check_module syms name sr entries ts
  5987: 
  5988:   | `AST_lookup (sr,(e,name,ts)) ->
  5989:     let result = eval_module_expr syms env e in
  5990:     begin match result with
  5991:       | Simple_module (index,ts',htab,dirs) ->
  5992:       let env' = mk_bare_env syms index in
  5993:       let tables = get_pub_tables syms env' rsground dirs in
  5994:       let result = lookup_name_in_table_dirs htab tables sr name in
  5995:         begin match result with
  5996:         | Some x ->
  5997:           check_module syms name sr x (ts' @ ts)
  5998: 
  5999:         | None -> clierr sr
  6000:           (
  6001:             "Can't find " ^ name ^ " in module"
  6002:           )
  6003:         end
  6004: 
  6005:     end
  6006: 
  6007:   | _ ->
  6008:     let sr = src_of_expr e in
  6009:     clierr sr
  6010:     (
  6011:       "Invalid module expression " ^
  6012:       string_of_expr e
  6013:     )
  6014: 
  6015: 
End ocaml section to src/flx_lookup.ml[1]