5.33. Build Symbol tables

Name binding, pass 1.

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.

Start ocaml section to src/flx_symtab.mli[1 /1 ]
     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: 
End ocaml section to src/flx_symtab.mli[1]
Start ocaml section to src/flx_symtab.ml[1 /1 ]
     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: 
End ocaml section to src/flx_symtab.ml[1]