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