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