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