5.65. Display calcs

Start ocaml section to src/flx_display.mli[1 /1 ]
     1: # 4 "./lpsrc/flx_display.ipk"
     2: open Flx_types
     3: open Flx_ast
     4: open Flx_mtypes2
     5: 
     6: val get_display_list:
     7:   sym_state_t ->
     8:   fully_bound_symbol_table_t ->
     9:   bid_t ->
    10:   (bid_t * int) list
    11: 
    12: val cal_display:
    13:   sym_state_t ->
    14:   fully_bound_symbol_table_t ->
    15:   bid_t option ->
    16:   (bid_t * int) list
    17: 
    18: val strd:
    19:   string list -> property_t list -> string
    20: 
End ocaml section to src/flx_display.mli[1]
Start ocaml section to src/flx_display.ml[1 /1 ]
     1: # 25 "./lpsrc/flx_display.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_util
     5: open List
     6: open Flx_mtypes2
     7: 
     8: (* This routine calculates the display a routine with
     9:   a given PARENT requires, which includes that parent
    10:   if it exists.
    11: 
    12:   The result is list of pairs, each pair consisting
    13:   of the ancestor and its vs subdisplay length,
    14:   with the inner most ancestor towards at head of list,
    15:   in particular the parent is always at the head of
    16:   the list if it is empty, and the most global scope
    17:   is at the end of the list.
    18: 
    19:   Note this is the reverse? of the order used to actually pass
    20:   the display entries to constructors, which start with
    21:   the thread frame (definitely) and work inwards (I think, maybe?? ..)
    22:   Hmmm .. should check ..
    23: *)
    24: 
    25: let cal_display syms bbdfns parent : (bid_t *int) list =
    26:   let rec aux parent display =
    27:     match parent with
    28:     | None -> rev display
    29:     | Some parent ->
    30:     match
    31:       try Some (Hashtbl.find bbdfns parent)
    32:       with Not_found ->  None
    33:     with
    34:     | Some (_,parent',sr,`BBDCL_class (_,vs))
    35:     | Some (_,parent',sr,`BBDCL_procedure (_,vs,_,_))
    36:     | Some (_,parent',sr,`BBDCL_function (_,vs,_,_,_))
    37:     | Some (_,parent',sr,`BBDCL_regmatch (_,vs,_,_,_))
    38:     | Some (_,parent',sr,`BBDCL_reglex (_,vs,_,_,_,_))
    39:     | Some (_,parent',sr,`BBDCL_glr (_,vs,_,_))
    40:       -> aux parent' ((parent,length vs)::display)
    41: 
    42:     (* typeclasses have to be treated 'as if' top level *)
    43:     (* MAY NEED REVISION! *)
    44:     | Some (_,parent',sr,`BBDCL_typeclass _ ) -> rev display
    45:     | None ->
    46:       begin
    47:         try
    48:           match Hashtbl.find syms.dfns parent with
    49:           (* instances have to be top level *)
    50:           | {id=id; symdef=`SYMDEF_instance _} -> rev display
    51:           | {id=id; symdef=`SYMDEF_typeclass } -> rev display
    52: 
    53:           | {id=id} ->
    54:             failwith ("[cal_display] Can't find index(1) " ^id^"<"^ si parent^">")
    55: 
    56:         with Not_found ->
    57:           failwith ("[cal_display] Can't find index(2) " ^ si parent)
    58:       end
    59: 
    60:     | _ -> assert false
    61:   in aux parent []
    62: 
    63: (* inner most at head of list *)
    64: let get_display_list syms bbdfns index : (bid_t * int) list =
    65:   tl (cal_display syms bbdfns (Some index))
    66: 
    67: let strd the_display props =
    68:   if length the_display = 0 then
    69:   (if mem `Requires_ptf props then "(FLX_FPAR_PASS_ONLY)" else "()")
    70:   else
    71:   (if mem `Requires_ptf props then "(FLX_FPAR_PASS " else "(") ^ cat ", " the_display ^ ")"
    72: 
End ocaml section to src/flx_display.ml[1]