![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to runtime.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / lib / twig|
Return to runtime.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / lib / twig |
1.1 root 1:
2: (* April 1989, Jussi Rintanen, Helsinki University of Technology *)
3:
4: (* This is the signature of a specification generated by ML-Twig *)
5:
6: signature TWIG_SPECIFICATION =
7: sig
8: type cost and tree and result
9: eqtype rule and symbol
10:
11: val get_subtrees : tree -> tree list
12: val node_value : tree -> symbol
13: val cost_less : cost * cost -> bool
14:
15: datatype skeletal = Skeleton of rule * cost * tree * skeletal list
16:
17: exception MatchAbort and InternalError of string
18:
19: val execute_cost : rule * tree * skeletal list -> cost
20: val execute : skeletal -> result
21: val getreplacement : result -> tree
22: val rewriterule : rule -> bool
23: val matches : rule -> int
24:
25: (* Definitions for unit rule matches and the tree pattern matching automaton *)
26:
27: eqtype state
28:
29: datatype matchtree = Chain of rule * symbol * matchtree list
30: val unitmatches : symbol -> matchtree list
31:
32: val childsymbol : int -> symbol
33: val initialstate : state
34: val go : state * symbol -> state
35: val go_f : state * symbol -> (int * rule * symbol) list
36: end;
37:
38: (* This functor maps a specification to a structure containing a complete tree
39: processor program and associated definitions. *)
40:
41: functor MAKEtreeprocessor ( Specification : TWIG_SPECIFICATION) =
42: struct
43: structure Spec : TWIG_SPECIFICATION = Specification
44:
45: open Spec
46:
47: exception NoCover
48:
49: fun internal s = raise InternalError ("FATAL:"^s)
50:
51: (* The structure representation implements a data type for
52: maintaining information of the matching tree pattern
53: matching process. The actual implementation is left
54: unspecified in the signature. However, because of the
55: match mode rewrite, an implementation without side effects
56: is required. *)
57:
58: structure Representation :
59: sig
60: type 's table
61: structure Spec : TWIG_SPECIFICATION
62:
63: val empty_table : unit -> 's table
64: val new_level : 's table -> 's table
65: val contribute0 : 's table * int * Spec.rule * Spec.symbol -> 's table
66: val contribute1 : 's table * int * Spec.rule * Spec.symbol * 's -> 's table
67: val get_level : 's table -> (Spec.symbol * (Spec.rule * int * 's list) list) list * 's table
68: end
69: =
70: struct
71:
72: (* The table is a list, where the head contains the match information
73: for the current node of the user tree. The tail of the list
74: contains the match information for the ancestors of the current
75: node. The match information for a node is an ordered list of pairs,
76: where the first member is the number of the non-terminal, to which
77: the matches in the second member contribute.
78: The matches for a non-terminal are in an ordered list of triples
79: rule * number of matches * children skeletons. *)
80:
81: structure Spec = Spec
82:
83: open Spec
84:
85: type 's table = (symbol * (rule * int * 's list) list) list list
86: fun empty_table () = []
87: fun new_level l = []::l
88: fun insert0' (r:rule,nil) = [(r,1,[])]
89: | insert0' (r:rule,(h as (r',m',s'))::hs) =
90: if r' <> r
91: then h :: insert0' (r,hs)
92: else (r,m'+1,s')::hs
93: fun insert0 (nil,r,t:symbol) = [(t,[(r,1,[])])]
94: | insert0 ((h as (t',a))::hs,r,t) =
95: if t' <> t
96: then h :: insert0 (hs,r,t)
97: else (t,insert0' (r,a))::hs
98: fun insert1' (r:rule,s,nil) = [(r,1,[s])]
99: | insert1' (r,s,(h as (r',m',s'))::hs) =
100: if r' <> r
101: then h :: insert1' (r,s,hs)
102: else (r,m'+1,s::s')::hs
103: fun insert1 (nil,r,t:symbol,s) = [(t,[(r,1,[s])])]
104: | insert1 ((h as (t',a))::hs,r,t,s) =
105: if t' <> t
106: then h :: insert1 (hs,r,t,s)
107: else (t,insert1' (r,s,a)):: hs
108: fun contribute0 (a::l,1,r,t) = insert0 (a,r,t) :: l
109: | contribute0 (a::l,n,r,t) = a::contribute0(l,n-1,r,t)
110: | contribute0 _ = internal "run out of levels"
111: fun contribute1 (a::l,1,r,t,s) = insert1(a,r,t,s) :: l
112: | contribute1 (a::l,n,r,t,s) = a::contribute1(l,n-1,r,t,s)
113: | contribute1 _ = internal "run out of levels"
114: fun get_level (a::l) = (a,l)
115: | get_level _ = internal "run out of levels"
116: end
117:
118: open Representation
119:
120: (* Utility functions *)
121:
122: val accum = revfold
123:
124: fun cost (Skeleton(_,c,_,_)) = c
125:
126: fun insert (i:symbol, s, nil) = [(i,s)]
127: | insert (i, s, (head as (i',s'))::rest) =
128: if i = i'
129: then
130: if cost_less (cost s,cost s')
131: then (i,s)::rest
132: else head::rest
133: else head :: (insert (i,s,rest))
134:
135: fun build_skeleton (ar as (r,t,cs)) = Skeleton (r,execute_cost ar,t,rev cs)
136:
137: (* get_closure takes four arguments. The first is a unit rule tree.
138: The second is the sub-skeleton in the unit rule match. The third
139: is the ir-tree of the current node, and the fourth is the list
140: of skeletons generated so far. The skeleton list consists of pairs:
141: the first element is the number of the non-terminal of the rule,
142: and the second element is the skeleton. *)
143:
144: fun get_closure (ct,ss,t,ac) =
145: accum (fn (Chain(r,n,cs),ac') =>
146: let val skel = build_skeleton(r,t,ss)
147: in
148: get_closure (cs,[skel],t,insert (n,skel,ac'))
149: end handle MatchAbort => ac')
150: ct ac
151:
152: fun someone (t,still_best, nil) = [still_best]
153: | someone (t,still_best, (r,m,cs)::rest) =
154: if matches r = m
155: then
156: let val skel = build_skeleton (r,t,cs)
157: in someone (t,if cost_less (cost skel,cost still_best)
158: then skel
159: else still_best,rest)
160: end handle MatchAbort => someone (t,still_best,rest)
161: else someone(t,still_best,rest)
162:
163: fun still_no_one (t,nil) = nil
164: | still_no_one (t,(r,m,cs)::rest) =
165: if matches r = m
166: then someone (t,build_skeleton (r,t,cs),rest)
167: handle MatchAbort => still_no_one (t,rest)
168: else still_no_one (t,rest)
169:
170: fun leave_best_alone (t,nil) = internal "matcher state inconsistent. lba."
171: | leave_best_alone (t,l) = still_no_one (t,l)
172:
173: fun skeletons_of (state,node,tab) =
174: let val (t,s) =
175: case get_subtrees node of
176: nil =>
177: let val tab' =
178: accum (fn ((h,r,n),t) => contribute0 (t,h-1,r,n))
179: (go_f(state, node_value node)) tab
180: in
181: (tab', get_closure ((unitmatches o node_value) node,[],node,[]))
182: end
183: | ls =>
184: let val state' = go (state, node_value node)
185: val (table, _) =
186: accum (fn (l,(t,i)) =>
187: let val state'' = go (state',childsymbol i)
188: val (t', ss) = skeletons_of (state'',l,t)
189: in (accum (fn ((r,s),t'') =>
190: let val finals = go_f (state'',r)
191: in
192: accum
193: (fn ((h,r,n),t''') =>
194: contribute1 (t''',h-1,r,n,s))
195: finals t''
196: end) ss t',i+1)
197: end)
198: ls
199: (new_level tab, 1)
200: val (toplevel, table') = get_level table
201: in
202: (table',
203: let val unclosurized = accum (fn ((_,nil),l) => l | ((n,[e]),l) => (n,e)::l | _ => internal "inconsistency. 01l")
204: (map (fn (n,sl) => (n,leave_best_alone (node,sl))) toplevel)
205: nil
206: in
207: accum (fn ((n,s),al) =>
208: get_closure (unitmatches n,[s],node,al)) unclosurized unclosurized
209: end)
210: end
211: in
212: case s of
213: [] => (t,[])
214: | [(_,S as Skeleton(r,_,_,_))] =>
215: if rewriterule r
216: then skeletons_of(state,(getreplacement o execute) S,tab)
217: else (t,s)
218: | (_,sk)::rest =>
219: let val best as Skeleton (r,_,_,_) =
220: accum (fn ((n,s),bs) =>
221: if cost_less (cost s,cost bs) then s else bs) rest sk
222: in
223: if rewriterule r
224: then skeletons_of(state,
225: (getreplacement o execute) best,
226: tab)
227: else (t,s)
228: end
229: end
230:
231: fun translate t = execute
232: (case (skeletons_of (initialstate,t,empty_table())) of
233: (_,(_,s)::t) =>
234: accum (fn ((n,s),bs) =>
235: if cost_less (cost s,cost bs) then s else bs) t s
236: | (_,nil) => raise NoCover)
237:
238: end;
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.