1: # 21 "./lpsrc/flx_display.ipk"
2: open Flx_ast
3: open Flx_types
4: open Flx_util
5: open List
6:
7: (* This routine calculates the display a routine with
8: a given PARENT requires, which includes that parent
9: if it exists.
10:
11: The result is list of pairs, each pair consisting
12: of the ancestor and its vs subdisplay length,
13: with the inner most ancestor towards at head of list,
14: in particular the parent is always at the head of
15: the list if it is empty, and the most global scope
16: is at the end of the list.
17:
18: Note this is the reverse? of the order used to actually pass
19: the display entries to constructors, which start with
20: the thread frame (definitely) and work inwards (I think, maybe?? ..)
21: Hmmm .. should check ..
22: *)
23:
24: let cal_display bbdfns parent : (bid_t *int) list =
25: let rec aux parent display =
26: match parent with
27: | None -> rev display
28: | Some parent ->
29: match
30: try Hashtbl.find bbdfns parent
31: with Not_found ->
32: failwith ("[cal_display] Can't find index " ^ si parent)
33: with
34: | _,parent',sr,`BBDCL_class (_,vs)
35: | _,parent',sr,`BBDCL_procedure (_,vs,_,_)
36: | _,parent',sr,`BBDCL_function (_,vs,_,_,_)
37: | _,parent',sr,`BBDCL_regmatch (_,vs,_,_,_)
38: | _,parent',sr,`BBDCL_reglex (_,vs,_,_,_,_)
39: | _,parent',sr,`BBDCL_glr (_,vs,_,_)
40: -> aux parent' ((parent,length vs)::display)
41: | _ -> assert false
42: in aux parent []
43:
44: (* inner most at head of list *)
45: let get_display_list bbdfns index : (bid_t * int) list =
46: tl (cal_display bbdfns (Some index))
47:
48: let strd the_display props =
49: if length the_display = 0 then
50: (if mem `Requires_ptf props then "(FLX_FPAR_PASS_ONLY)" else "()")
51: else
52: (if mem `Requires_ptf props then "(FLX_FPAR_PASS " else "(") ^ cat ", " the_display ^ ")"
53: