67 |
67 |
68 |
68 |
69 (** tables of translation functions **) |
69 (** tables of translation functions **) |
70 |
70 |
71 fun mk_trfun (c, f) = (c, (f, stamp ())); |
71 fun mk_trfun (c, f) = (c, (f, stamp ())); |
72 fun eq_trfuns ((c1:string, (_, s1:stamp)), (c2, (_, s2))) = c1 = c2 andalso s1 = s2; |
72 fun eq_trfuns ((_, s1:stamp), (_, s2)) = s1 = s2; |
73 |
73 |
74 |
74 |
75 (* parse (ast) translations *) |
75 (* parse (ast) translations *) |
76 |
76 |
77 fun lookup_tr tab c = apsome fst (Symtab.lookup (tab, c)); |
77 fun lookup_tr tab c = apsome fst (Symtab.lookup (tab, c)); |
89 |
89 |
90 |
90 |
91 (* print (ast) translations *) |
91 (* print (ast) translations *) |
92 |
92 |
93 fun lookup_tr' tab c = map fst (Symtab.lookup_multi (tab, c)); |
93 fun lookup_tr' tab c = map fst (Symtab.lookup_multi (tab, c)); |
94 |
94 fun extend_tr'tab tab trfuns = foldr Symtab.update_multi (map mk_trfun trfuns, tab); |
95 fun extend_tr'tab tab trfuns = |
95 fun merge_tr'tabs tab1 tab2 = Symtab.merge_multi' eq_trfuns (tab1, tab2); |
96 generic_extend eq_trfuns Symtab.dest_multi Symtab.make_multi tab (map mk_trfun trfuns); |
|
97 |
|
98 fun merge_tr'tabs tabs = generic_merge eq_trfuns Symtab.dest_multi Symtab.make_multi tabs; |
|
99 |
96 |
100 |
97 |
101 |
98 |
102 (** tables of token translation functions **) |
99 (** tables of token translation functions **) |
103 |
100 |
145 |
142 |
146 |
143 |
147 (* empty, extend, merge ruletabs *) |
144 (* empty, extend, merge ruletabs *) |
148 |
145 |
149 fun extend_ruletab tab rules = |
146 fun extend_ruletab tab rules = |
150 generic_extend (op =) Symtab.dest_multi Symtab.make_multi tab |
147 foldr Symtab.update_multi (map (fn r => (Ast.head_of_rule r, r)) rules, tab); |
151 (map (fn r => (Ast.head_of_rule r, r)) (distinct rules)); |
148 |
152 |
149 fun merge_ruletabs tab1 tab2 = Symtab.merge_multi' (op =) (tab1, tab2); |
153 fun merge_ruletabs tab1 tab2 = |
|
154 generic_merge (op =) Symtab.dest_multi Symtab.make_multi tab1 tab2; |
|
155 |
150 |
156 |
151 |
157 |
152 |
158 (** datatype syntax **) |
153 (** datatype syntax **) |
159 |
154 |
204 parse_ast_translation, parse_rules, parse_translation, print_translation, print_rules, |
199 parse_ast_translation, parse_rules, parse_translation, print_translation, print_rules, |
205 print_ast_translation, token_translation} = syn_ext; |
200 print_ast_translation, token_translation} = syn_ext; |
206 in |
201 in |
207 Syntax { |
202 Syntax { |
208 lexicon = if inout then Scan.extend_lexicon lexicon (SynExt.delims_of xprods) else lexicon, |
203 lexicon = if inout then Scan.extend_lexicon lexicon (SynExt.delims_of xprods) else lexicon, |
209 logtypes = extend_list logtypes1 logtypes2, |
204 logtypes = merge_lists logtypes1 logtypes2, |
210 gram = if inout then Parser.extend_gram gram xprods else gram, |
205 gram = if inout then Parser.extend_gram gram xprods else gram, |
211 consts = consts2 @ consts1, |
206 consts = consts2 @ consts1, |
212 prmodes = (mode ins_string prmodes2) union_string prmodes1, |
207 prmodes = (mode ins_string prmodes2) union_string prmodes1, |
213 parse_ast_trtab = |
208 parse_ast_trtab = |
214 extend_trtab parse_ast_trtab parse_ast_translation "parse ast translation", |
209 extend_trtab parse_ast_trtab parse_ast_translation "parse ast translation", |
348 val {lexicon, gram, parse_ast_trtab, logtypes, ...} = tabs; |
343 val {lexicon, gram, parse_ast_trtab, logtypes, ...} = tabs; |
349 val root' = if root mem logtypes then SynExt.logic else root; |
344 val root' = if root mem logtypes then SynExt.logic else root; |
350 val chars = Symbol.explode str; |
345 val chars = Symbol.explode str; |
351 val pts = Parser.parse gram root' (Lexicon.tokenize lexicon xids chars); |
346 val pts = Parser.parse gram root' (Lexicon.tokenize lexicon xids chars); |
352 |
347 |
353 fun show_pt pt = warning (Pretty.string_of |
348 fun show_pt pt = |
354 (Ast.pretty_ast (SynTrans.pt_to_ast (K None) pt))); |
349 warning (Pretty.string_of (Ast.pretty_ast (SynTrans.pt_to_ast (K None) pt))); |
355 in |
350 in |
356 if length pts > ! ambiguity_level then |
351 if length pts > ! ambiguity_level then |
357 (warning ("Ambiguous input " ^ quote str); |
352 (warning ("Ambiguous input " ^ quote str); |
358 warning "produces the following parse trees:"; |
353 warning "produces the following parse trees:"; |
359 seq show_pt pts) |
354 seq show_pt pts) |