This module is responsible for converting the AST into a symbol table, type 1. This table represents the raw information, nesting structure, and associates each entity with a unique index.
Types, expressions, and bodies of functions remain unbound.
1: # 15 "./lpsrc/flx_symtab.ipk" 2: open Flx_ast 3: open Flx_types 4: open Flx_mtypes2 5: 6: val build_tables: 7: sym_state_t -> 8: string -> 9: ivs_list_t -> 10: int -> 11: int option -> (* parent index *) 12: int option -> (* grandparent index *) 13: int -> (* root index *) 14: bool -> (* true if parent is a class, false otherwise *) 15: asm_t list -> 16: ( 17: name_map_t * 18: name_map_t * 19: sexe_t list * 20: (range_srcref * iface_t * int option) list * 21: dir_t list 22: ) 23:
1: # 39 "./lpsrc/flx_symtab.ipk" 2: open Flx_util 3: open Flx_ast 4: open Flx_types 5: open Flx_mtypes2 6: open Flx_print 7: open Flx_typing 8: open Flx_srcref 9: open List 10: open Flx_lookup 11: open Flx_exceptions 12: 13: (* use fresh variables, but preserve names *) 14: let mkentry syms (vs:ivs_list_t) i = 15: let n = length (fst vs) in 16: let base = !(syms.counter) in syms.counter := !(syms.counter) + n; 17: let ts = map (fun i -> `BTYP_var (i+base,`BTYP_type 0)) (nlist n) in 18: let vs = map2 (fun i (n,_,_) -> n,i+base) (nlist n) (fst vs) in 19: (* 20: print_endline ("Make entry " ^ si i ^ ", " ^ "vs =" ^ 21: catmap "," (fun (s,i) -> s^ "<" ^ si i ^">") vs ^ 22: ", ts=" ^ catmap "," (sbt syms.dfns) ts 23: ); 24: *) 25: {base_sym=i; spec_vs=vs; sub_ts=ts} 26: 27: let merge_ivs 28: (vs1,{raw_type_constraint=con1; raw_typeclass_reqs=rtcr1}) 29: (vs2,{raw_type_constraint=con2; raw_typeclass_reqs=rtcr2}) 30: :ivs_list_t = 31: let t = 32: match con1,con2 with 33: | `TYP_tuple[],`TYP_tuple[] -> `TYP_tuple[] 34: | `TYP_tuple[],b -> b 35: | a,`TYP_tuple[] -> a 36: | `TYP_intersect a, `TYP_intersect b -> `TYP_intersect (a@b) 37: | `TYP_intersect a, b -> `TYP_intersect (a @[b]) 38: | a,`TYP_intersect b -> `TYP_intersect (a::b) 39: | a,b -> `TYP_intersect [a;b] 40: and 41: rtcr = uniq_list (rtcr1 @ rtcr2) 42: in 43: vs1 @ vs2, 44: { raw_type_constraint=t; raw_typeclass_reqs=rtcr} 45: 46: 47: 48: let split_asms asms : 49: (range_srcref * id_t * int option * access_t * vs_list_t * dcl_t) list * 50: sexe_t list * 51: (range_srcref * iface_t) list * 52: dir_t list 53: = 54: let rec aux asms dcls exes ifaces dirs = 55: match asms with 56: | [] -> (dcls,exes,ifaces, dirs) 57: | h :: t -> 58: match h with 59: | `Exe (sr,exe) -> aux t dcls ((sr,exe) :: exes) ifaces dirs 60: | `Dcl (sr,id,seq,access,vs,dcl) -> aux t ((sr,id,seq,access,vs,dcl) :: dcls) exes ifaces dirs 61: | `Iface (sr,iface) -> aux t dcls exes ((sr,iface) :: ifaces) dirs 62: | `Dir dir -> aux t dcls exes ifaces (dir::dirs) 63: in 64: aux asms [] [] [] [] 65: 66: let dump_name_to_int_map level name name_map = 67: let spc = spaces level in 68: print_endline (spc ^ "//Name to int map for " ^ name); 69: print_endline (spc ^ "//---------------"); 70: Hashtbl.iter 71: ( 72: fun id n -> 73: print_endline ( "//" ^ spc ^ id ^ ": " ^ si n) 74: ) 75: name_map 76: ; 77: print_endline "" 78: 79: let strp = function | Some x -> si x | None -> "none" 80: 81: let full_add_unique syms sr (vs:ivs_list_t) table key value = 82: try 83: let entry = Hashtbl.find table key in 84: match entry with 85: | `NonFunctionEntry (idx) 86: | `FunctionEntry (idx :: _ ) -> 87: (match Hashtbl.find syms.dfns (sye idx) with 88: | { sr=sr2 } -> 89: clierr2 sr sr2 90: ("[build_tables] Duplicate non-function " ^ key ^ "<"^si (sye idx)^">") 91: ) 92: | `FunctionEntry [] -> assert false 93: with Not_found -> 94: Hashtbl.add table key (`NonFunctionEntry (mkentry syms vs value)) 95: 96: let full_add_function syms sr (vs:ivs_list_t) table key value = 97: try 98: match Hashtbl.find table key with 99: | `NonFunctionEntry entry -> 100: begin 101: match Hashtbl.find syms.dfns ( sye entry ) with 102: { id=id; sr=sr2 } -> 103: clierr2 sr sr2 104: ( 105: "[build_tables] Cannot overload " ^ 106: key ^ "<" ^ si value ^ ">" ^ 107: " with non-function " ^ 108: id ^ "<" ^ si (sye entry) ^ ">" 109: ) 110: end 111: 112: | `FunctionEntry fs -> 113: Hashtbl.remove table key; 114: Hashtbl.add table key (`FunctionEntry (mkentry syms vs value :: fs)) 115: with Not_found -> 116: Hashtbl.add table key (`FunctionEntry [mkentry syms vs value]) 117: 118: (* this routine takes a partially filled unbound definition table, 119: 'dfns' and a counter 'counter', and adds entries to the table 120: at locations equal to and above the counter 121: 122: Each entity is also added to the name map of the parent entity. 123: 124: We use recursive descent, noting that the whilst an entity 125: is not registered until its children are completely registered, 126: its index is allocated before descending into child structures, 127: so the index of children is always higher than its parent numerically 128: 129: The parent index is passed down so an uplink to the parent can 130: be created in the child, but it cannot be followed until 131: registration of all the children and their parent is complete 132: *) 133: 134: let null_tab = Hashtbl.create 3 135: let dfltvs_aux = { raw_type_constraint=`TYP_tuple []; raw_typeclass_reqs=[]} 136: let dfltvs = [],dfltvs_aux 137: 138: 139: let rec build_tables syms name inherit_vs 140: level parent grandparent root is_class asms 141: = 142: (* 143: print_endline ("//Building tables for " ^ name); 144: *) 145: let 146: print_flag = syms.compiler_options.print_flag and 147: dfns = syms.dfns and 148: counter = syms.counter 149: in 150: let dcls,exes,ifaces,export_dirs = split_asms asms in 151: let dcls,exes,ifaces,export_dirs = 152: rev dcls,rev exes,rev ifaces, rev export_dirs 153: in 154: let ifaces = map (fun (i,j)-> i,j,parent) ifaces in 155: let interfaces = ref ifaces in 156: let spc = spaces level in 157: let pub_name_map = Hashtbl.create 97 in 158: let priv_name_map = Hashtbl.create 97 in 159: 160: (* check root index *) 161: if level = 0 162: then begin 163: if root <> !counter 164: then failwith "Wrong value for root index"; 165: begin match dcls with 166: | [x] -> () 167: | _ -> failwith "Expected top level to contain exactly one module declaration" 168: end 169: ; 170: if name <> "root" 171: then failwith 172: ("Expected top level to be called root, got " ^ name) 173: end 174: else 175: if name = "root" 176: then failwith ("Can't name non-toplevel module 'root'") 177: else 178: Hashtbl.add priv_name_map "root" (`NonFunctionEntry (mkentry syms dfltvs root)) 179: ; 180: begin 181: iter 182: ( 183: fun (sr,id,seq,access,vs',dcl) -> 184: let pubtab = Hashtbl.create 3 in (* dummy-ish table could contain type vars *) 185: let privtab = Hashtbl.create 3 in (* dummy-ish table could contain type vars *) 186: let n = match seq with 187: | Some n -> (* print_endline ("SPECIAL " ^ id ^ si n); *) n 188: | None -> let n = !counter in incr counter; n 189: in 190: if print_flag then begin 191: let kind = match dcl with 192: | `DCL_class _ -> "(class) " 193: | `DCL_function _ -> "(function) " 194: | `DCL_module _ -> "(module) " 195: | `DCL_insert _ -> "(insert) " 196: | `DCL_typeclass _ -> "(typeclass) " 197: | `DCL_instance _ -> "(instance) " 198: | `DCL_fun _ -> "(fun) " 199: | `DCL_var _ -> "(var) " 200: | `DCL_val _ -> "(val) " 201: | _ -> "" 202: in 203: print_endline 204: ( 205: "//" ^ spc ^ si n ^ " -> " ^ id ^ 206: " " ^ kind ^ short_string_of_src sr 207: ) 208: end; 209: let make_vs (vs',con) : ivs_list_t = 210: map 211: ( 212: fun (tid,tpat)-> let n = !counter in incr counter; 213: if print_flag then 214: print_endline ("// "^spc ^ si n ^ " -> " ^ tid^ " (type variable)"); 215: tid,n,tpat 216: ) 217: vs' 218: , 219: con 220: in 221: let vs = make_vs vs' in 222: 223: (* 224: begin 225: match vs with (_,{raw_typeclass_reqs=rtcr})-> 226: match rtcr with 227: | _::_ -> 228: print_endline (id^": TYPECLASS REQUIREMENTS " ^ 229: catmap "," string_of_qualified_name rtcr); 230: | [] -> (); 231: end; 232: let rec addtc tcin dirsout = match tcin with 233: | [] -> rev dirsout 234: | h::t -> 235: addtc t (DIR_typeclass_req h :: dirsout); 236: in 237: let typeclass_dirs = 238: match vs with (_,{raw_typeclass_reqs=rtcr})-> addtc rtcr [] 239: in 240: *) 241: 242: let add_unique table id idx = full_add_unique syms sr (merge_ivs vs inherit_vs) table id idx in 243: let add_function table id idx = full_add_function syms sr (merge_ivs vs inherit_vs) table id idx in 244: let add_tvars' parent table vs = 245: iter 246: (fun (tvid,i,tpat) -> 247: let mt = match tpat with 248: | `AST_patany _ -> `TYP_type (* default/unspecified *) 249: (* 250: | #suffixed_name_t as name -> 251: print_endline ("Decoding type variable " ^ si i ^ " kind"); 252: print_endline ("Hacking suffixed kind name " ^ string_of_suffixed_name name ^ " to TYPE"); 253: `TYP_type (* HACK *) 254: *) 255: 256: | `TYP_none -> `TYP_type 257: | `TYP_ellipsis -> clierr sr "Ellipsis ... as metatype" 258: | _ -> tpat 259: in 260: Hashtbl.add dfns i 261: { 262: id=tvid; 263: sr=sr; 264: parent=parent; 265: vs=dfltvs; 266: pubmap=null_tab; 267: privmap=null_tab; 268: dirs=[]; 269: symdef=`SYMDEF_typevar mt 270: }; 271: add_unique table tvid i 272: ) 273: (fst vs) 274: in 275: let add_tvars table = add_tvars' (Some n) table vs in 276: 277: let handle_class class_kind classno sts tvars stype = 278: if print_flag then 279: print_endline ("//Interfaces for class " ^ si classno); 280: (* projections *) 281: iter 282: (fun mem -> 283: let kind, component_name,component_index,mvs,t,cc = 284: match mem with 285: | `MemberVar (n,t,cc) -> `Var,n,None,dfltvs,t,cc 286: | `MemberVal (n,t,cc) -> `Val,n,None,dfltvs,t,cc 287: | `MemberFun (n,mix,vs,t,cc) -> `Fun,n,mix,vs,t,cc 288: | `MemberProc (n,mix,vs,t,cc) -> `Proc,n,mix,vs,t,cc 289: | `MemberCtor (n,mix,t,cc) -> `Ctor,n,mix,dfltvs,t,cc 290: in 291: (* 292: print_endline ("//Member " ^ component_name); 293: print_endline ("vs= " ^ catmap "," (fun (n,i)->n) (fst mvs)); 294: *) 295: let mtvars = map (fun (s,_)-> `AST_name (sr,s,[])) (fst mvs) in 296: if print_flag then 297: print_endline ("//Member " ^ component_name); 298: if kind = `Ctor && class_kind = `CClass then 299: begin 300: let ctor_index = !(syms.counter) in incr (syms.counter); 301: let ctor_name = "_ctor_" ^ id in 302: let ct = 303: match vs with 304: | [],_ -> `StrTemplate("new "^ id^"($a)") 305: | _ -> `StrTemplate("new "^ id^"<?a>($a)") 306: in 307: let argst = match t with 308: | `TYP_tuple ls -> ls 309: | x -> [x] 310: in 311: let symdef = `SYMDEF_fun ([],argst,stype,ct,`NREQ_true,"primary") in 312: Hashtbl.add dfns ctor_index { 313: id=ctor_name;sr=sr;parent=parent; 314: vs=vs;pubmap=pubtab;privmap=privtab;dirs=[]; 315: symdef=symdef 316: } 317: ; 318: if access = `Public then add_function pub_name_map ctor_name ctor_index; 319: add_function priv_name_map ctor_name ctor_index; 320: if print_flag then print_endline ("// " ^ spc ^ si ctor_index ^ " -> " ^ ctor_name ^ " [ctor]") 321: end 322: ; 323: 324: if (kind = `Fun || kind = `Proc) then 325: begin 326: let domain,codomain = 327: match t with 328: | `TYP_function (domain,codomain) when kind = `Fun -> 329: domain,codomain 330: | domain when kind = `Proc -> 331: domain,`AST_void sr 332: | _ -> clierr sr "Accessor method must have function type" 333: in 334: let obj_name = "_a_" ^ component_name in 335: let getn = !counter in incr counter; 336: let get_name = "get_" ^ component_name in 337: let props = [] in 338: let ps = [stype] in 339: if print_flag then 340: print_endline "//Get method for function"; 341: 342: (* the return type of the get_f function *) 343: let rett = `TYP_function (domain,codomain) in 344: (* add parameters to symbol table of the function, 345: there is only one, namely the object 346: *) 347: let objidx = !counter in incr counter; 348: let get_asms = 349: if class_kind = `CClass || cc <> None then 350: begin 351: (* make applicator method. This precisely the function: 352: 353: fun get_f(x:X) (a:arg_t): result_t => exec_f (x,a); 354: 355: which reduces to 356: 357: fun get_f(x:X): arg_t -> result_t = { 358: fun do_f(a:arg_t): result_t = { 359: fun exec_f: X * arg_t -> result_t = "$1->f($b)"; 360: return exec_f (x,a); 361: } 362: return do_f; 363: } 364: 365: *) 366: 367: (* make the execute method *) 368: let argts = match domain with 369: | `TYP_tuple ls -> ls 370: | x -> [x] 371: in 372: 373: (* The exec method *) 374: let execn = !counter in incr counter; 375: let exec_name = "exec_" ^ component_name in 376: let exec_asm = 377: let cc = 378: match cc with Some cc -> cc | None -> 379: let trail = 380: (match codomain with `AST_void _ -> ";" | _ -> "") 381: in 382: `StrTemplate("$1->" ^ component_name^"($b)" ^ trail) 383: in 384: `Dcl (sr,exec_name,Some execn,`Private,dfltvs, (* vs inherited *) 385: `DCL_fun ([],stype::argts,codomain, cc,`NREQ_true,"primary") 386: ) 387: in 388: 389: (* the do method *) 390: let don = !counter in incr counter; 391: let do_name = "_do_" ^ component_name in 392: let do_asm = 393: let f = `AST_index (sr,exec_name,execn) in 394: let cnt = ref 1 in 395: let params = 396: map 397: (fun t -> 398: let i = !cnt in incr cnt; 399: let pname = "_" ^ si i in 400: (`PVal,pname,t) 401: ) 402: argts 403: in 404: let args = map (fun(_,n,_)->n) params in 405: let arg = `AST_tuple (sr, map (fun n -> `AST_name (sr,n,[])) (obj_name::args)) in 406: let asms = 407: [ 408: `Exe (sr, 409: (match codomain with 410: | `AST_void _ -> `EXE_call (f,arg) 411: | _ -> `EXE_fun_return (`AST_apply(sr,(f,arg))) 412: ) 413: ); 414: exec_asm 415: ] 416: in 417: `Dcl (sr,do_name,Some don, `Private,dfltvs, (* vs inherited *) 418: `DCL_function ((params,None),codomain,[],asms) 419: ) 420: in 421: let get_asms = 422: [ 423: `Exe (sr,`EXE_fun_return (`AST_index (sr,do_name,don))); 424: do_asm 425: ] 426: in 427: get_asms 428: end else begin 429: match component_index with 430: | None -> assert false 431: | Some mix -> 432: let get_asms = 433: [ 434: `Exe 435: ( 436: sr, 437: `EXE_fun_return 438: ( 439: `AST_get_named_method 440: ( 441: sr, 442: ( 443: component_name, mix,mtvars, 444: `AST_index (sr,obj_name,objidx) 445: ) 446: ) 447: ) 448: ) 449: ] 450: in 451: get_asms 452: end 453: in 454: begin 455: if print_flag then 456: print_endline ("//Building tables for " ^ get_name); 457: let pubtab,privtab, exes, ifaces,dirs = 458: build_tables syms get_name dfltvs (level+1) 459: (Some getn) parent root false get_asms 460: in 461: (* print_endline "Making fresh type variables"; *) 462: let vs = make_vs vs' in 463: let mvs = make_vs mvs in 464: add_tvars' (Some getn) privtab (merge_ivs vs mvs); 465: (* add the get method to the current sumbol table *) 466: if print_flag then 467: print_endline ("//Adding get method " ^ get_name ^ " with vs=" ^ 468: print_ivs_with_index (merge_ivs vs mvs) ^ ", parent = " ^ strp parent 469: ); 470: Hashtbl.add dfns getn { 471: id=get_name;sr=sr;parent=parent; 472: vs=merge_ivs vs mvs;pubmap=pubtab;privmap=privtab;dirs=dirs; 473: symdef=`SYMDEF_function ( 474: ([`PVal,obj_name,stype],None), rett, props, exes 475: ) 476: }; 477: let xvs = merge_ivs vs mvs in 478: let xvs = merge_ivs inherit_vs xvs in 479: (* 480: print_endline ("ADDING class method " ^ get_name); 481: print_endline ("vs= " ^ catmap "," (fun (n,i,_)->n) (fst xvs)); 482: *) 483: full_add_function syms sr xvs pub_name_map get_name getn; 484: full_add_function syms sr xvs priv_name_map get_name getn; 485: (* 486: add_function pub_name_map get_name getn; 487: add_function priv_name_map get_name getn; 488: *) 489: 490: (* add parameter now *) 491: if print_flag then 492: print_endline ("// "^spc ^ si objidx ^ " -> " ^ obj_name^ " (parameter)"); 493: Hashtbl.add dfns objidx { 494: id=obj_name;sr=sr;parent=Some getn;vs=dfltvs; 495: pubmap=null_tab;privmap=null_tab;dirs=[]; 496: symdef=`SYMDEF_parameter (`PVal,stype) 497: }; 498: if access = `Public then add_unique pubtab obj_name objidx; 499: add_unique privtab obj_name objidx; 500: 501: interfaces := !interfaces @ ifaces 502: ; 503: if print_flag then 504: print_endline ("// " ^ spc ^ si getn ^ " -> " ^ get_name) 505: end 506: end 507: ; 508: if kind = `Var || kind = `Val then 509: begin 510: if print_flag then 511: print_endline "//Get method for variable"; 512: let getn = !counter in incr counter; 513: let get_name = "get_" ^ component_name in 514: let funtab = Hashtbl.create 3 in 515: let vs = make_vs vs' in 516: add_tvars' (Some getn) funtab vs; 517: (* add the get method to the current sumbol table *) 518: if print_flag then 519: print_endline ("//Adding get method " ^ get_name ^ " with vs=" ^ 520: print_ivs_with_index vs ^ ", parent = " ^ strp parent 521: ); 522: let get_dcl = 523: if class_kind = `CClass then 524: `SYMDEF_fun ([],[stype],t, 525: `StrTemplate("$1->" ^ component_name), 526: `NREQ_true,"primary" 527: ) 528: else 529: let objix = !(syms.counter) in incr syms.counter; 530: let objname = "obj" in 531: Hashtbl.add dfns objix { 532: id=objname;sr=sr;parent=Some getn; 533: vs=dfltvs;pubmap=null_tab;privmap=null_tab; 534: dirs=[];symdef=`SYMDEF_parameter (`PVal,stype) 535: }; 536: add_unique funtab objname objix; 537: let ps = [`PVal,"obj",stype],None in 538: let exes = [sr, 539: `EXE_fun_return (`AST_get_named_variable (sr, 540: (component_name,`AST_index (sr,"obj",objix)) 541: )) 542: ] 543: in 544: `SYMDEF_function (ps,t,[`Inline],exes) 545: in 546: (* the get function, lives outside class *) 547: Hashtbl.add dfns getn { 548: id=get_name;sr=sr;parent=parent;vs=vs; 549: pubmap=funtab;privmap=funtab;dirs=[]; 550: symdef=get_dcl 551: }; 552: if access = `Public then add_function pub_name_map get_name getn; 553: add_function priv_name_map get_name getn 554: ; 555: (* 556: print_endline ("Added " ^ get_name ^ " to class parent"); 557: *) 558: if print_flag then 559: print_endline ("// " ^ spc ^ si getn ^ " -> " ^ get_name) 560: end 561: ; 562: (* LVALUE VARIATION *) 563: if kind = `Var then 564: begin 565: let funtab = Hashtbl.create 3 in 566: let getn = !counter in incr counter; 567: let get_name = "get_" ^ component_name in 568: let vs = make_vs vs' in 569: add_tvars' (Some getn) funtab vs; 570: let get_dcl = 571: if class_kind = `CClass then 572: `SYMDEF_fun ([],[`TYP_lvalue stype],`TYP_lvalue t, 573: `StrTemplate ("$1->" ^ component_name), 574: `NREQ_true,"primary" 575: ) 576: else 577: let objix = !(syms.counter) in incr syms.counter; 578: let objname = "obj" in 579: Hashtbl.add dfns objix { 580: id=objname;sr=sr;parent=Some getn; 581: vs=dfltvs;pubmap=null_tab;privmap=null_tab; 582: dirs=[];symdef=`SYMDEF_parameter (`PVal,`TYP_lvalue stype) 583: }; 584: add_unique funtab objname objix; 585: let ps = [`PVal,"obj",`TYP_lvalue stype],None in 586: let exes = [sr, 587: `EXE_fun_return (`AST_get_named_variable (sr, 588: (component_name,`AST_index (sr,"obj",objix)) 589: )) 590: ] 591: in 592: `SYMDEF_function (ps,`TYP_lvalue t,[`Inline],exes) 593: in 594: Hashtbl.add dfns getn { 595: id=get_name;sr=sr;parent=parent;vs=vs; 596: pubmap=funtab;privmap=funtab;dirs=[]; 597: symdef=get_dcl 598: }; 599: if access = `Public then add_function pub_name_map get_name getn; 600: add_function priv_name_map get_name getn 601: ; 602: if print_flag then 603: print_endline ("// " ^ spc ^ si getn ^ " -> " ^ get_name ^ " [lvalue]") 604: end 605: 606: ) 607: sts 608: ; 609: if print_flag then 610: print_endline "//---- end interface----"; 611: in 612: begin match (dcl:dcl_t) with 613: | `DCL_regdef re -> 614: if is_class then clierr sr "Regdef not allowed in class"; 615: Hashtbl.add dfns n {id=id;sr=sr;parent=parent;vs=vs;pubmap=pubtab;privmap=privtab;dirs=[];symdef=`SYMDEF_regdef re}; 616: if access = `Public then add_unique pub_name_map id n; 617: add_unique priv_name_map id n 618: ; 619: add_tvars privtab 620: 621: | `DCL_regmatch cls -> 622: if is_class then clierr sr "Regmatch not allowed in class"; 623: let lexmod = `AST_name (sr,"Lexer",[]) in 624: let ptyp = `AST_lookup (sr,(lexmod,"iterator",[])) in 625: 626: let p1 = !(syms.counter) in incr syms.counter; 627: let p2 = !(syms.counter) in incr syms.counter; 628: add_unique privtab "lexeme_start" p1; 629: add_unique privtab "buffer_end" p2; 630: Hashtbl.add dfns p1 {id="lexeme_start";sr=sr; 631: parent=Some n;vs=vs; 632: pubmap=Hashtbl.create 3;privmap=Hashtbl.create 3;dirs=[]; 633: symdef=`SYMDEF_parameter (`PVal,ptyp) 634: }; 635: 636: Hashtbl.add dfns p2 {id="buffer_end";sr=sr; 637: parent=Some n;vs=vs; 638: pubmap=Hashtbl.create 3;privmap=Hashtbl.create 3;dirs=[]; 639: symdef=`SYMDEF_parameter (`PVal,ptyp) 640: }; 641: 642: let ps = [`PVal,"lexeme_start",ptyp; `PVal,"buffer_end",ptyp],None in 643: 644: 645: Hashtbl.add dfns n {id=id;sr=sr;parent=parent; 646: vs=vs; pubmap=pubtab;privmap=privtab;dirs=[]; 647: symdef=`SYMDEF_regmatch (ps,cls) 648: }; 649: if access = `Public then add_unique pub_name_map id n; 650: add_unique priv_name_map id n 651: ; 652: add_tvars privtab 653: 654: | `DCL_reglex cls -> 655: if is_class then clierr sr "Reglex not allowed in class"; 656: let lexmod = `AST_name (sr,"Lexer",[]) in 657: let ptyp = `AST_lookup (sr,(lexmod,"iterator",[])) in 658: 659: let p1 = !(syms.counter) in incr syms.counter; 660: let p2 = !(syms.counter) in incr syms.counter; 661: let v3 = !(syms.counter) in incr syms.counter; 662: 663: add_unique privtab "lexeme_start" p1; 664: add_unique privtab "buffer_end" p2; 665: add_unique privtab "lexeme_end" v3; 666: 667: Hashtbl.add dfns p1 {id="lexeme_start";sr=sr; 668: parent=Some n;vs=vs; 669: pubmap=Hashtbl.create 3;privmap=Hashtbl.create 3;dirs=[]; 670: symdef=`SYMDEF_parameter (`PVal,ptyp) 671: }; 672: 673: Hashtbl.add dfns p2 {id="buffer_end";sr=sr; 674: parent=Some n;vs=vs; 675: pubmap=Hashtbl.create 3;privmap=Hashtbl.create 3;dirs=[]; 676: symdef=`SYMDEF_parameter (`PVal,ptyp) 677: }; 678: 679: Hashtbl.add dfns v3 {id="lexeme_end";sr=sr; 680: parent=Some n;vs=vs; 681: pubmap=Hashtbl.create 3;privmap=Hashtbl.create 3;dirs=[]; 682: symdef=`SYMDEF_var ptyp 683: }; 684: 685: let ps = [`PVal,"lexeme_start",ptyp; `PVal,"buffer_end",ptyp],None in 686: 687: Hashtbl.add dfns n {id=id;sr=sr;parent=parent; 688: vs=vs;pubmap=pubtab;privmap=privtab;dirs=[]; 689: symdef=`SYMDEF_reglex (ps,v3,cls) 690: }; 691: if access = `Public then add_unique pub_name_map id n; 692: add_unique priv_name_map id n 693: ; 694: add_tvars privtab 695: 696: 697: | `DCL_reduce (ps,e1,e2) -> 698: let fun_index = n in 699: let ips = ref [] in 700: iter (fun (name,typ) -> 701: let n = !counter in incr counter; 702: if print_flag then 703: print_endline ("// "^spc ^ si n ^ " -> " ^ name^ " (parameter)"); 704: Hashtbl.add dfns n { 705: id=name;sr=sr;parent=Some fun_index; 706: vs=dfltvs;pubmap=null_tab;privmap=null_tab; 707: dirs=[];symdef=`SYMDEF_parameter (`PVal,typ) 708: }; 709: if access = `Public then add_unique pubtab name n; 710: add_unique privtab name n; 711: ips := (`PVal,name,typ) :: !ips 712: ) ps 713: ; 714: Hashtbl.add dfns fun_index { 715: id=id;sr=sr;parent=parent;vs=vs; 716: pubmap=pubtab;privmap=privtab;dirs=[]; 717: symdef=`SYMDEF_reduce (rev !ips, e1, e2) 718: }; 719: ; 720: add_tvars privtab 721: 722: | `DCL_axiom ((ps,pre),e1) -> 723: let fun_index = n in 724: let ips = ref [] in 725: iter (fun (k,name,typ) -> 726: let n = !counter in incr counter; 727: if print_flag then 728: print_endline ("// "^spc ^ si n ^ " -> " ^ name^ " (parameter)"); 729: Hashtbl.add dfns n { 730: id=name;sr=sr;parent=Some fun_index; 731: vs=dfltvs;pubmap=null_tab;privmap=null_tab; 732: dirs=[];symdef=`SYMDEF_parameter (k,typ) 733: }; 734: if access = `Public then add_unique pubtab name n; 735: add_unique privtab name n; 736: ips := (k,name,typ) :: !ips 737: ) ps 738: ; 739: Hashtbl.add dfns fun_index { 740: id=id;sr=sr;parent=parent;vs=vs; 741: pubmap=pubtab;privmap=privtab;dirs=[]; 742: symdef=`SYMDEF_axiom ((rev !ips, pre),e1) 743: }; 744: ; 745: add_tvars privtab 746: 747: | `DCL_lemma ((ps,pre),e1) -> 748: let fun_index = n in 749: let ips = ref [] in 750: iter (fun (k,name,typ) -> 751: let n = !counter in incr counter; 752: if print_flag then 753: print_endline ("// "^spc ^ si n ^ " -> " ^ name^ " (parameter)"); 754: Hashtbl.add dfns n { 755: id=name;sr=sr;parent=Some fun_index; 756: vs=dfltvs;pubmap=null_tab;privmap=null_tab; 757: dirs=[];symdef=`SYMDEF_parameter (k,typ) 758: }; 759: if access = `Public then add_unique pubtab name n; 760: add_unique privtab name n; 761: ips := (k,name,typ) :: !ips 762: ) ps 763: ; 764: Hashtbl.add dfns fun_index { 765: id=id;sr=sr;parent=parent;vs=vs; 766: pubmap=pubtab;privmap=privtab;dirs=[]; 767: symdef=`SYMDEF_lemma ((rev !ips, pre),e1) 768: }; 769: ; 770: add_tvars privtab 771: 772: 773: | `DCL_function ((ps,pre),t,props,asms) -> 774: let is_ctor = mem `Ctor props in 775: 776: if is_ctor && id <> "__constructor__" 777: then syserr sr 778: "Function with constructor property not named __constructor__" 779: ; 780: 781: if is_ctor && not is_class 782: then clierr sr 783: "Constructors must be defined directly inside a class" 784: ; 785: 786: if is_ctor then 787: begin match t with 788: | `AST_void _ -> () 789: | _ -> syserr sr 790: "Constructor should return type void" 791: end 792: ; 793: 794: (* change the name of a constructor to the class name 795: prefixed by _ctor_ 796: *) 797: let id = if is_ctor then "_ctor_" ^ name else id in 798: (* 799: if is_class && not is_ctor then 800: print_endline ("TABLING METHOD " ^ id ^ " OF CLASS " ^ name); 801: *) 802: let fun_index = n in 803: let t = if t = `TYP_none then `TYP_var fun_index else t in 804: let pubtab,privtab, exes, ifaces,dirs = 805: build_tables syms id dfltvs (level+1) 806: (Some fun_index) parent root false asms 807: in 808: let ips = ref [] in 809: iter (fun (k,name,typ) -> 810: let n = !counter in incr counter; 811: if print_flag then 812: print_endline ("// "^spc ^ si n ^ " -> " ^ name^ " (parameter)"); 813: Hashtbl.add dfns n { 814: id=name;sr=sr;parent=Some fun_index; 815: vs=dfltvs;pubmap=null_tab;privmap=null_tab; 816: dirs=[];symdef=`SYMDEF_parameter (k,typ) 817: }; 818: if access = `Public then add_unique pubtab name n; 819: add_unique privtab name n; 820: ips := (k,name,typ) :: !ips 821: ) ps 822: ; 823: Hashtbl.add dfns fun_index { 824: id=id;sr=sr;parent=parent;vs=vs; 825: pubmap=pubtab;privmap=privtab; 826: dirs=dirs; 827: symdef=`SYMDEF_function ((rev !ips,pre), t, props, exes) 828: }; 829: if access = `Public then add_function pub_name_map id fun_index; 830: add_function priv_name_map id fun_index; 831: interfaces := !interfaces @ ifaces 832: ; 833: add_tvars privtab 834: 835: | `DCL_match_check (pat,(mvname,match_var_index)) -> 836: if is_class then clierr sr "Match check not allowed in class"; 837: assert (length (fst vs) = 0); 838: let fun_index = n in 839: Hashtbl.add dfns fun_index { 840: id=id;sr=sr;parent=parent;vs=vs; 841: pubmap=pubtab;privmap=privtab;dirs=[]; 842: symdef=`SYMDEF_match_check (pat, (mvname,match_var_index))} 843: ; 844: if access = `Public then add_function pub_name_map id fun_index ; 845: add_function priv_name_map id fun_index ; 846: interfaces := !interfaces @ ifaces 847: ; 848: add_tvars privtab 849: 850: | `DCL_match_handler (pat,(mvname,match_var_index),asms) -> 851: if is_class then clierr sr "Match handler not allowed in class"; 852: (* 853: print_endline ("Parent is " ^ match parent with Some i -> si i); 854: print_endline ("Match handler, "^si n^", mvname = " ^ mvname); 855: *) 856: assert (length (fst vs) = 0); 857: let vars = Hashtbl.create 97 in 858: Flx_mbind.get_pattern_vars vars pat []; 859: (* 860: print_endline ("PATTERN IS " ^ string_of_pattern pat ^ ", VARIABLE=" ^ mvname); 861: print_endline "VARIABLES ARE"; 862: Hashtbl.iter (fun vname (sr,extractor) -> 863: let component = 864: Flx_mbind.gen_extractor extractor (`AST_index (sr,mvname,match_var_index)) 865: in 866: print_endline (" " ^ vname ^ " := " ^ string_of_expr component); 867: ) vars; 868: *) 869: 870: let new_asms = ref asms in 871: Hashtbl.iter 872: (fun vname (sr,extractor) -> 873: let component = 874: Flx_mbind.gen_extractor extractor 875: (`AST_index (sr,mvname,match_var_index)) 876: in 877: let dcl = 878: `Dcl (sr, vname, None,`Private, dfltvs, 879: `DCL_val (`TYP_typeof (component)) 880: ) 881: and instr = `Exe (sr, `EXE_init (vname, component)) 882: in 883: new_asms := dcl :: instr :: !new_asms; 884: ) 885: vars; 886: (* 887: print_endline ("asms are" ^ string_of_desugared !new_asms); 888: *) 889: let fun_index = n in 890: let pubtab,privtab, exes,ifaces,dirs = 891: build_tables syms id dfltvs (level+1) 892: (Some fun_index) parent root false !new_asms 893: in 894: Hashtbl.add dfns fun_index { 895: id=id;sr=sr;parent=parent;vs=vs; 896: pubmap=pubtab;privmap=privtab; 897: dirs=dirs; 898: symdef=`SYMDEF_function (([],None),`TYP_var fun_index, [`Generated "symtab:match handler" ; `Inline],exes) 899: }; 900: if access = `Public then 901: add_function pub_name_map id fun_index; 902: add_function priv_name_map id fun_index; 903: interfaces := !interfaces @ ifaces 904: ; 905: add_tvars privtab 906: 907: 908: | `DCL_insert (s,ikind,reqs) -> 909: Hashtbl.add dfns n {id=id;sr=sr;parent=parent;vs=vs;pubmap=pubtab;privmap=privtab;dirs=[]; 910: symdef=`SYMDEF_insert (s,ikind,reqs) 911: }; 912: if access = `Public then add_function pub_name_map id n; 913: add_function priv_name_map id n 914: 915: | `DCL_module asms -> 916: if is_class then clierr sr "Module not allowed in class"; 917: let pubtab,privtab, exes,ifaces,dirs = 918: build_tables syms id (merge_ivs inherit_vs vs) 919: (level+1) (Some n) parent root false 920: asms 921: in 922: Hashtbl.add dfns n { 923: id=id;sr=sr; 924: parent=parent;vs=vs; 925: pubmap=pubtab;privmap=privtab; 926: dirs=dirs; 927: symdef=`SYMDEF_module 928: }; 929: let n' = !counter in 930: incr counter; 931: let init_def = `SYMDEF_function ( ([],None),`AST_void sr, [],exes) in 932: if print_flag then 933: print_endline ("// "^spc ^ si n' ^ " -> _init_ (module "^id^")"); 934: Hashtbl.add dfns n' {id="_init_";sr=sr;parent=Some n;vs=vs;pubmap=null_tab;privmap=null_tab;dirs=[];symdef=init_def}; 935: 936: if access = `Public then add_unique pub_name_map id n; 937: add_unique priv_name_map id n; 938: if access = `Public then add_function pubtab ("_init_") n'; 939: add_function privtab ("_init_") n'; 940: interfaces := !interfaces @ ifaces 941: ; 942: add_tvars privtab 943: 944: | `DCL_typeclass asms -> 945: (* 946: let symdef = `SYMDEF_typeclass in 947: let tvars = map (fun (s,_,_)-> `AST_name (sr,s,[])) (fst vs) in 948: let stype = `AST_name(sr,id,tvars) in 949: *) 950: if is_class then clierr sr "typeclass not allowed in class"; 951: 952: let pubtab,privtab, exes,ifaces,dirs = 953: build_tables syms id (merge_ivs inherit_vs vs) 954: (level+1) (Some n) parent root false 955: asms 956: in 957: let fudged_privtab = Hashtbl.create 97 in 958: let vsl = length (fst inherit_vs) + length (fst vs) in 959: (* 960: print_endline ("Strip " ^ si vsl ^ " vs"); 961: *) 962: let drop vs = 963: let keep = length vs - vsl in 964: if keep >= 0 then rev (list_prefix (rev vs) keep) 965: else failwith "WEIRD CASE" 966: in 967: let nts = map (fun (s,i,t)-> `BTYP_var (i,`BTYP_type 0)) (fst vs) in 968: (* fudge the private view to remove the vs *) 969: let show { base_sym=i; spec_vs=vs; sub_ts=ts } = 970: si i ^ " |-> " ^ 971: "vs= " ^catmap "," (fun (s,i) -> s^"<" ^si i^">") vs^ 972: "ts =" ^catmap "," (sbt syms.dfns) ts 973: in 974: let fixup ({ base_sym=i; spec_vs=vs; sub_ts=ts } as e) = 975: let e' = { 976: base_sym=i; 977: spec_vs=drop vs; 978: sub_ts=nts @ drop ts 979: } 980: in 981: (* 982: print_endline (show e ^ " ===> " ^ show e'); 983: *) 984: e' 985: in 986: Hashtbl.iter 987: (fun s es -> 988: (* 989: print_endline ("Entry " ^ s ); 990: *) 991: let nues = 992: if s = "root" then es else 993: match es with 994: | `NonFunctionEntry e -> 995: `NonFunctionEntry (fixup e) 996: | `FunctionEntry es -> 997: `FunctionEntry (map fixup es) 998: in 999: Hashtbl.add fudged_privtab s nues 1000: ) 1001: privtab 1002: ; 1003: Hashtbl.add dfns n { 1004: id=id;sr=sr;parent=parent; 1005: vs=vs;pubmap=pubtab;privmap=fudged_privtab;dirs=dirs; 1006: symdef=`SYMDEF_typeclass 1007: } 1008: ; 1009: if access = `Public then add_unique pub_name_map id n; 1010: add_unique priv_name_map id n; 1011: interfaces := !interfaces @ ifaces 1012: ; 1013: add_tvars fudged_privtab 1014: 1015: 1016: | `DCL_instance (qn,asms) -> 1017: if is_class then clierr sr "instance not allowed in class"; 1018: let pubtab,privtab, exes,ifaces,dirs = 1019: build_tables syms id dfltvs 1020: (level+1) (Some n) parent root false 1021: asms 1022: in 1023: Hashtbl.add dfns n { 1024: id=id;sr=sr; 1025: parent=parent;vs=vs; 1026: pubmap=pubtab;privmap=privtab; 1027: dirs=dirs; 1028: symdef=`SYMDEF_instance qn 1029: }; 1030: let inst_name = "_inst_" ^ id in 1031: if access = `Public then add_function pub_name_map inst_name n; 1032: add_function priv_name_map inst_name n; 1033: interfaces := !interfaces @ ifaces 1034: ; 1035: add_tvars privtab 1036: 1037: | `DCL_class asms -> 1038: if is_class then clierr sr "class not allowed in class"; 1039: let pubtab,privtab, exes,ifaces,dirs = 1040: build_tables syms id dfltvs (level+1) (Some n) parent root true 1041: asms 1042: in 1043: Hashtbl.add dfns n { 1044: id=id;sr=sr; 1045: parent=parent;vs=vs; 1046: pubmap=pubtab;privmap=privtab; 1047: dirs=dirs; 1048: symdef=`SYMDEF_class 1049: }; 1050: if access = `Public then add_unique pub_name_map id n; 1051: add_unique priv_name_map id n; 1052: interfaces := !interfaces @ ifaces 1053: ; 1054: add_tvars privtab 1055: ; 1056: let thisix = !(syms.counter) in incr counter; 1057: let dcl =`SYMDEF_const (`AST_index (sr,id,n),`Str "#this",`NREQ_true) in 1058: Hashtbl.add syms.dfns thisix { 1059: id="this";sr=sr;parent=Some n; vs=dfltvs; 1060: pubmap=null_tab; privmap=null_tab; 1061: dirs=[];symdef=dcl 1062: }; 1063: add_unique privtab "this" thisix; 1064: (* 1065: print_endline ("Added this: " ^ si thisix); 1066: *) 1067: 1068: (* Hack it by building an interface *) 1069: let tvars = map (fun (s,_,_)-> `AST_name (sr,s,[])) (fst vs) in 1070: let stype = `AST_name(sr,id,tvars) in 1071: 1072: 1073: (* THIS IS A SUPERIOR HACK!!!! *) 1074: let sts = ref [] in 1075: let detail {base_sym=idx} = 1076: match 1077: try Hashtbl.find syms.dfns idx 1078: with Not_found -> 1079: (* 1080: print_endline ("Wah! Can't find entry " ^ si idx); 1081: *) 1082: raise Not_found 1083: 1084: with 1085: | {id=id; vs=vs;symdef=symdef} -> 1086: let vs : vs_list_t = map (fun (s,i,pat) -> s,pat) (fst vs),snd vs in 1087: match symdef with 1088: | `SYMDEF_var t -> sts := `MemberVar (id,t,None) :: !sts 1089: | `SYMDEF_val t -> sts := `MemberVal (id,t,None) :: ! sts 1090: | `SYMDEF_function (ps,ret,props,_) -> 1091: if mem `Ctor props then () else 1092: let ps = map (fun(_,_,t)->t)(fst ps) in 1093: let a = match ps with 1094: | [x] -> x 1095: | x -> `TYP_tuple x 1096: in 1097: begin match ret with 1098: | `AST_void _ -> sts := `MemberProc (id,Some idx,vs,a,None) :: !sts 1099: | _ -> sts := `MemberFun (id,Some idx,vs,`TYP_function(a,ret),None) :: !sts 1100: end 1101: | _ -> () 1102: in 1103: let detail x = try detail x with Not_found -> () in 1104: Hashtbl.iter 1105: (fun id entry -> match entry with 1106: | `NonFunctionEntry idx -> detail idx 1107: | `FunctionEntry idxs -> iter detail idxs 1108: ) 1109: privtab 1110: ; 1111: handle_class `Class n (!sts) tvars stype 1112: 1113: | `DCL_val t -> 1114: let t = match t with | `TYP_none -> `TYP_var n | _ -> t in 1115: Hashtbl.add dfns n {id=id;sr=sr;parent=parent;vs=vs;pubmap=pubtab;privmap=privtab;dirs=[];symdef=`SYMDEF_val (t)} 1116: ; 1117: if access = `Public then add_unique pub_name_map id n; 1118: add_unique priv_name_map id n 1119: ; 1120: add_tvars privtab 1121: 1122: | `DCL_var t -> 1123: let t = if t = `TYP_none then `TYP_var n else t in 1124: Hashtbl.add dfns n {id=id;sr=sr;parent=parent;vs=vs;pubmap=pubtab;privmap=privtab;dirs=[];symdef=`SYMDEF_var (`TYP_lvalue t)} 1125: ; 1126: if access = `Public then add_unique pub_name_map id n; 1127: add_unique priv_name_map id n 1128: ; 1129: add_tvars privtab 1130: 1131: | `DCL_lazy (t,e) -> 1132: let t = if t = `TYP_none then `TYP_var n else t in 1133: Hashtbl.add dfns n {id=id;sr=sr;parent=parent;vs=vs;pubmap=pubtab;privmap=privtab;dirs=[];symdef=`SYMDEF_lazy (t,e)} 1134: ; 1135: if access = `Public then add_unique pub_name_map id n; 1136: add_unique priv_name_map id n 1137: ; 1138: add_tvars privtab 1139: 1140: | `DCL_ref t -> 1141: let t = match t with | `TYP_none -> `TYP_var n | _ -> t in 1142: Hashtbl.add dfns n {id=id;sr=sr;parent=parent;vs=vs;pubmap=pubtab;privmap=privtab;dirs=[];symdef=`SYMDEF_ref (t)} 1143: ; 1144: if access = `Public then add_unique pub_name_map id n; 1145: add_unique priv_name_map id n 1146: ; 1147: add_tvars privtab 1148: 1149: | `DCL_type_alias (t) -> 1150: if is_class then clierr sr "Type alias not allowed in class"; 1151: Hashtbl.add dfns n {id=id;sr=sr;parent=parent;vs=vs;pubmap=pubtab;privmap=privtab;dirs=[];symdef=`SYMDEF_type_alias t} 1152: ; 1153: (* this is a hack, checking for a type function this way, 1154: since it will also incorrectly recognize a type lambda like: 1155: 1156: typedef f = fun(x:TYPE)=>x; 1157: 1158: With ordinary functions: 1159: 1160: f := fun (x:int)=>x; 1161: 1162: initialises a value, and this f cannot be overloaded. 1163: 1164: That is, a closure (object) and a function (class) are 1165: distinguished .. this should be the same for type 1166: functions as well. 1167: 1168: EVEN WORSE: our system is getting confused with 1169: unbound type variables which are HOLES in types, and 1170: parameters, which are bound variables: the latter 1171: are really just the same as type aliases where 1172: the alias isn't known. The problem is that we usually 1173: substitute names with what they alias, but we can't 1174: for parameters, so we replace them with undistinguished 1175: type variables. 1176: 1177: Consequently, for a type function with a type 1178: function as a parameter, the parameter name is being 1179: overloaded when it is applied, which is wrong. 1180: 1181: We need to do what we do with ordinary function: 1182: put the parameter names into the symbol table too: 1183: lookup_name_with_sig can handle this, because it checks 1184: both function set results and non-function results. 1185: *) 1186: begin match t with 1187: | `TYP_typefun _ 1188: | `TYP_case _ -> 1189: if access = `Public then add_function pub_name_map id n; 1190: add_function priv_name_map id n 1191: | _ -> 1192: if access = `Public then add_unique pub_name_map id n; 1193: add_unique priv_name_map id n 1194: end; 1195: add_tvars privtab 1196: 1197: | `DCL_inherit qn -> 1198: Hashtbl.add dfns n 1199: {id=id;sr=sr;parent=parent;vs=vs;pubmap=pubtab; 1200: privmap=privtab;dirs=[];symdef=`SYMDEF_inherit qn} 1201: ; 1202: if access = `Public then add_unique pub_name_map id n; 1203: add_unique priv_name_map id n 1204: ; 1205: add_tvars privtab 1206: 1207: | `DCL_inherit_fun qn -> 1208: if is_class then clierr sr "inherit clause not allowed in class"; 1209: Hashtbl.add dfns n 1210: {id=id;sr=sr;parent=parent;vs=vs;pubmap=pubtab; 1211: privmap=privtab;dirs=[];symdef=`SYMDEF_inherit_fun qn} 1212: ; 1213: if access = `Public then add_function pub_name_map id n; 1214: add_function priv_name_map id n 1215: ; 1216: add_tvars privtab 1217: 1218: | `DCL_newtype t -> 1219: if is_class then clierr sr "Type abstraction not allowed in class"; 1220: Hashtbl.add dfns n { 1221: id=id;sr=sr;parent=parent;vs=vs; 1222: pubmap=pubtab;privmap=privtab;dirs=[]; 1223: symdef=`SYMDEF_newtype t 1224: } 1225: ; 1226: let n_repr = !(syms.counter) in incr (syms.counter); 1227: let piname = `AST_name (sr,id,[]) in 1228: Hashtbl.add dfns n_repr { 1229: id="_repr_";sr=sr;parent=parent;vs=vs; 1230: pubmap=pubtab;privmap=privtab;dirs=[]; 1231: symdef=`SYMDEF_fun ([],[piname],t,`Identity,`NREQ_true,"expr") 1232: } 1233: ; 1234: add_function priv_name_map "_repr_" n_repr 1235: ; 1236: let n_make = !(syms.counter) in incr (syms.counter); 1237: Hashtbl.add dfns n_make { 1238: id="_make_"^id;sr=sr;parent=parent;vs=vs; 1239: pubmap=pubtab;privmap=privtab;dirs=[]; 1240: symdef=`SYMDEF_fun ([],[t],piname,`Identity,`NREQ_true,"expr") 1241: } 1242: ; 1243: add_function priv_name_map ("_make_"^id) n_make 1244: ; 1245: if access = `Public then add_unique pub_name_map id n; 1246: add_unique priv_name_map id n 1247: ; 1248: add_tvars privtab 1249: 1250: | `DCL_abs (quals,c, reqs) -> 1251: if is_class then clierr sr "Type binding not allowed in class"; 1252: Hashtbl.add dfns n { 1253: id=id;sr=sr;parent=parent;vs=vs; 1254: pubmap=pubtab;privmap=privtab;dirs=[]; 1255: symdef=`SYMDEF_abs (quals,c,reqs) 1256: } 1257: ; 1258: if access = `Public then add_unique pub_name_map id n; 1259: add_unique priv_name_map id n 1260: ; 1261: add_tvars privtab 1262: 1263: | `DCL_const (t,c, reqs) -> 1264: if is_class then clierr sr "Const binding not allowed in class"; 1265: let t = if t = `TYP_none then `TYP_var n else t in 1266: Hashtbl.add dfns n {id=id;sr=sr;parent=parent;vs=vs; 1267: pubmap=pubtab;privmap=privtab;dirs=[]; 1268: symdef=`SYMDEF_const (t,c,reqs) 1269: } 1270: ; 1271: if access = `Public then add_unique pub_name_map id n; 1272: add_unique priv_name_map id n 1273: ; 1274: add_tvars privtab 1275: 1276: | `DCL_glr (t,(p,e)) -> 1277: if is_class then clierr sr "GLR parsing not allowed in class"; 1278: let fun_index = n in 1279: let asms = [`Exe (sr,`EXE_fun_return e)] in 1280: let pubtab,privtab, exes, ifaces,dirs = 1281: build_tables syms id dfltvs (level+1) 1282: (Some fun_index) parent root false asms 1283: in 1284: let ips = ref [] in 1285: iter (fun (name,typ) -> 1286: match name with 1287: | None -> () 1288: | Some name -> 1289: let n = !counter in incr counter; 1290: if print_flag then 1291: print_endline ("// "^spc ^ si n ^ " -> " ^ name^ ": "^string_of_typecode (typ:> typecode_t)^" (glr parameter)"); 1292: Hashtbl.add dfns n { 1293: id=name;sr=sr;parent=Some fun_index;vs=dfltvs; 1294: pubmap=null_tab; 1295: privmap=null_tab;dirs=[]; 1296: symdef=`SYMDEF_const (`TYP_glr_attr_type typ, 1297: `Str ("*"^name),`NREQ_true 1298: ) 1299: }; 1300: if access = `Public then add_unique pubtab name n; 1301: add_unique privtab name n; 1302: ips := (name,typ) :: !ips 1303: ) p 1304: ; 1305: 1306: Hashtbl.add dfns n {id=id;sr=sr;parent=parent;vs=vs; 1307: pubmap=pubtab;privmap=privtab;dirs=dirs; 1308: symdef=`SYMDEF_glr (t,(p,exes))} 1309: ; 1310: if access = `Public then add_function pub_name_map id n; 1311: add_function priv_name_map id n 1312: ; 1313: add_tvars privtab 1314: ; 1315: 1316: 1317: | `DCL_fun (props, ts,t,c,reqs,prec) -> 1318: Hashtbl.add dfns n { 1319: id=id;sr=sr;parent=parent;vs=vs; 1320: pubmap=pubtab;privmap=privtab;dirs=[]; 1321: symdef=`SYMDEF_fun (props, ts,t,c,reqs,prec) 1322: } 1323: ; 1324: if access = `Public then add_function pub_name_map id n; 1325: add_function priv_name_map id n 1326: ; 1327: add_tvars privtab 1328: 1329: (* A callback is just like a C function binding .. only it 1330: actually generates the function. It has a special argument 1331: the C function has as type void*, but which Felix must 1332: consider as the type of a closure with the same type 1333: as the C function, with this void* dropped. 1334: *) 1335: | `DCL_callback (props, ts,t,reqs) -> 1336: Hashtbl.add dfns n {id=id;sr=sr;parent=parent;vs=vs;pubmap=pubtab;privmap=privtab;dirs=[]; 1337: symdef=`SYMDEF_callback (props, ts,t,reqs)} 1338: ; 1339: if access = `Public then add_function pub_name_map id n; 1340: add_function priv_name_map id n 1341: ; 1342: add_tvars privtab 1343: 1344: | `DCL_union (its) -> 1345: if is_class then clierr sr "Union not allowed in class"; 1346: let tvars = map (fun (s,_,_)-> `AST_name (sr,s,[])) (fst vs) in 1347: let utype = `AST_name(sr,id, tvars) in 1348: let its = 1349: let ccount = ref 0 in (* count component constructors *) 1350: map (fun (component_name,v,vs,t) -> 1351: (* ctor sequence in union *) 1352: let ctor_idx = match v with 1353: | None -> !ccount 1354: | Some i -> ccount := i; i 1355: in 1356: incr ccount 1357: ; 1358: component_name,ctor_idx,vs,t 1359: ) 1360: its 1361: in 1362: 1363: Hashtbl.add dfns n { 1364: id=id;sr=sr;parent=parent;vs=vs; 1365: pubmap=pubtab;privmap=privtab;dirs=[]; 1366: symdef=`SYMDEF_union (its) 1367: } 1368: ; 1369: if access = `Public then add_unique pub_name_map id n; 1370: add_unique priv_name_map id n 1371: ; 1372: 1373: let unit_sum = 1374: fold_left 1375: (fun v (_,_,_,t) -> v && (match t with `AST_void _ -> true | _ -> false) ) 1376: true 1377: its 1378: in 1379: iter 1380: (fun (component_name,ctor_idx,vs',t) -> 1381: let dfn_idx = !counter in incr counter; (* constructor *) 1382: let match_idx = !counter in incr counter; (* matcher *) 1383: 1384: (* existential type variables *) 1385: let evs = make_vs vs' in 1386: add_tvars' (Some dfn_idx) privtab evs; 1387: let ctor_dcl2 = 1388: if unit_sum 1389: then begin 1390: if access = `Public then add_unique pub_name_map component_name dfn_idx; 1391: add_unique priv_name_map component_name dfn_idx; 1392: `SYMDEF_const_ctor (n,utype,ctor_idx,evs) 1393: end 1394: else 1395: match t with 1396: | `AST_void _ -> (* constant constructor *) 1397: if access = `Public then add_unique pub_name_map component_name dfn_idx; 1398: add_unique priv_name_map component_name dfn_idx; 1399: `SYMDEF_const_ctor (n,utype,ctor_idx,evs) 1400: 1401: | `TYP_tuple ts -> (* non-constant constructor or 2 or more arguments *) 1402: if access = `Public then add_function pub_name_map component_name dfn_idx; 1403: add_function priv_name_map component_name dfn_idx; 1404: `SYMDEF_nonconst_ctor (n,utype,ctor_idx,evs,t) 1405: 1406: | _ -> (* non-constant constructor of 1 argument *) 1407: if access = `Public then add_function pub_name_map component_name dfn_idx; 1408: add_function priv_name_map component_name dfn_idx; 1409: `SYMDEF_nonconst_ctor (n,utype,ctor_idx,evs,t) 1410: in 1411: 1412: if print_flag then print_endline ("// " ^ spc ^ si dfn_idx ^ " -> " ^ component_name); 1413: Hashtbl.add dfns dfn_idx { 1414: id=component_name;sr=sr;parent=parent; 1415: vs=vs; 1416: pubmap=pubtab; 1417: privmap=privtab; 1418: dirs=[]; 1419: symdef=ctor_dcl2 1420: }; 1421: ) 1422: its 1423: ; 1424: add_tvars privtab 1425: 1426: | `DCL_cclass (sts) -> 1427: if is_class then clierr sr "cclass not allowed in class"; 1428: let symdef = `SYMDEF_cclass sts in 1429: let tvars = map (fun (s,_,_)-> `AST_name (sr,s,[])) (fst vs) in 1430: let stype = `AST_name(sr,id,tvars) in 1431: Hashtbl.add dfns n { 1432: id=id;sr=sr;parent=parent; 1433: vs=vs;pubmap=pubtab;privmap=privtab;dirs=[]; 1434: symdef=symdef 1435: } 1436: ; 1437: if access = `Public then add_unique pub_name_map id n; 1438: add_unique priv_name_map id n 1439: ; 1440: add_tvars privtab 1441: ; 1442: let dont_care = 0 in 1443: handle_class `CClass dont_care sts tvars stype 1444: 1445: | `DCL_cstruct (sts) 1446: | `DCL_struct (sts) -> 1447: if is_class then clierr sr "(c)struct not allowed in class"; 1448: let tvars = map (fun (s,_,_)-> `AST_name (sr,s,[])) (fst vs) in 1449: let stype = `AST_name(sr,id,tvars) in 1450: Hashtbl.add dfns n { 1451: id=id;sr=sr;parent=parent; 1452: vs=vs;pubmap=pubtab;privmap=privtab;dirs=[]; 1453: symdef=( 1454: match dcl with 1455: | `DCL_struct _ -> `SYMDEF_struct (sts) 1456: | `DCL_cstruct _ -> `SYMDEF_cstruct (sts) 1457: | _ -> assert false 1458: ) 1459: } 1460: ; 1461: if access = `Public then add_unique pub_name_map id n; 1462: add_unique priv_name_map id n 1463: ; 1464: (* 1465: (* projections *) 1466: iter 1467: (fun (component_name,t) -> 1468: begin 1469: let getn = !counter in incr counter; 1470: let get_name = "get_" ^ component_name in 1471: let get_dcl = `SYMDEF_fun ([],[stype],t, 1472: `StrTemplate("$1." ^ component_name), 1473: `NREQ_true,"primary") 1474: in 1475: Hashtbl.add dfns getn { 1476: id=get_name;sr=sr;parent=parent;vs=vs; 1477: pubmap=pubtab;privmap=privtab;dirs=[]; 1478: symdef=get_dcl 1479: }; 1480: if access = `Public then add_function pub_name_map get_name getn; 1481: add_function priv_name_map get_name getn 1482: ; 1483: if print_flag then print_endline ("// " ^ spc ^ si getn ^ " -> " ^ get_name) 1484: end 1485: ; 1486: (* LVALUE VARIATION *) 1487: begin 1488: let getn = !counter in incr counter; 1489: let get_name = "get_" ^ component_name in 1490: let get_dcl = `SYMDEF_fun ([],[`TYP_lvalue stype], 1491: `TYP_lvalue t, 1492: `StrTemplate ("$1." ^ component_name), 1493: `NREQ_true,"primary") 1494: in 1495: Hashtbl.add dfns getn { 1496: id=get_name;sr=sr;parent=parent;vs=vs; 1497: pubmap=pubtab;privmap=privtab;dirs=[]; 1498: symdef=get_dcl 1499: }; 1500: if access = `Public then add_function pub_name_map get_name getn; 1501: add_function priv_name_map get_name getn 1502: ; 1503: if print_flag then print_endline ("//[lvalue] " ^ spc ^ si getn ^ " -> " ^ get_name) 1504: end 1505: ; 1506: 1507: ) 1508: sts 1509: ; 1510: *) 1511: add_tvars privtab 1512: 1513: (* NOTE: we don't add a type constructor for struct, because 1514: it would have the same name as the struct type .. 1515: we just check this case as required 1516: *) 1517: end 1518: ) 1519: dcls 1520: end 1521: ; 1522: pub_name_map,priv_name_map,exes,!interfaces, export_dirs 1523: