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.
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:
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: