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: