1structure parse_term :> parse_term = 2struct 3 4open Lib 5open errormonad term_tokens term_grammar HOLgrammars 6open GrammarSpecials PrecAnalysis 7open parse_term_dtype 8 9infix >> >- ++ >-> 10 11val syntax_error_trace = ref true 12val _ = Feedback.register_btrace ("syntax_error", syntax_error_trace) 13 14fun WARN f msg = if !syntax_error_trace then 15 Feedback.HOL_WARNING "parse_term" f msg 16 else () 17fun WARNloc f loc msg = if !syntax_error_trace then 18 Feedback.HOL_WARNINGloc "parse_term" f loc msg 19 else () 20 21fun noloc s = (s, locn.Loc_None) 22fun qfail x = error (noloc "") x 23fun WARNloc_string loc s = (s, loc) 24 25fun PRINT s = print (s ^ "\n") 26 27exception Failloc of (locn.locn * string) 28fun FAILloc locn s = raise Failloc (locn, s) 29 30fun liftlocn f (x,locn) = (f x,locn) 31 32exception ParseTermError of string locn.located 33type 'a token = 'a term_tokens.term_token 34type 'a qbuf = 'a qbuf.qbuf 35 36 37fun insert_sorted (k, v) [] = [(k, v)] 38 | insert_sorted kv1 (wholething as (kv2::rest)) = let 39 val (k1, _) = kv1 40 val (k2, _) = kv2 41 in 42 if (k1 < k2) then kv1::wholething 43 else kv2::insert_sorted kv1 rest 44 end 45 46 47fun listtoString f [] = "[]" 48 | listtoString f xs = let 49 fun lf [x] = f x 50 | lf (x::xs) = f x ^ ", " ^ lf xs 51 | lf _ = raise Fail "Can't happen" 52 in 53 "[" ^ lf xs ^ "]" 54 end 55 56fun fragtoString (QUOTE s) = s 57 | fragtoString (ANTIQUOTE _) = " ^... " 58fun quotetoString [] = "" 59 | quotetoString (x::xs) = fragtoString x ^ quotetoString xs 60 61 62datatype 'a varstruct 63 = SIMPLE of string 64 | VPAIR of ('a varstruct locn.located * 'a varstruct locn.located) 65 | TYPEDV of 'a varstruct locn.located * Pretype.pretype locn.located 66 | RESTYPEDV of 'a varstruct locn.located * 'a preterm locn.located 67 | VS_AQ of 'a 68and 'a preterm 69 = COMB of ('a preterm locn.located * 'a preterm locn.located) 70 | VAR of string 71 | QIDENT of string * string 72 | ABS of ('a varstruct locn.located * 'a preterm locn.located) 73 | AQ of 'a 74 | TYPED of ('a preterm locn.located * Pretype.pretype locn.located) 75 76infix -- 77fun (l1 -- []) = l1 78 | (l1 -- (x::xs)) = List.filter (fn y => y <> x) l1 -- xs 79 80fun all_tokens strlist = 81 map STD_HOL_TOK strlist @ [BOS, EOS, Id, TypeColon, TypeTok, EndBinding] 82 83exception PrecConflict of stack_terminal * stack_terminal 84 85val complained_already = ref false; 86 87structure Polyhash = 88struct 89 fun peek (dict) k = Binarymap.peek(!dict,k) 90 fun peekInsert r (k,v) = 91 let val dict = !r in 92 case Binarymap.peek(dict,k) of 93 NONE => (r := Binarymap.insert(dict,k,v); NONE) 94 | x => x 95 end 96 fun insert r (k,v) = 97 r := Binarymap.insert(!r,k,v) 98 fun listItems dict = Binarymap.listItems (!dict) 99 fun mkDict cmp = let 100 val newref = ref (Binarymap.mkDict cmp) 101 in 102 newref 103 end 104end 105 106local 107 val rule_elements = term_grammar.rule_elements o #elements 108in 109fun rule_left (rr: rule_record) = 110 case hd (rule_elements rr) of 111 TOK s => STD_HOL_TOK s 112 | _ => raise Fail ("rule list is bogus for "^ #term_name rr) 113end 114 115fun left_grabbing_elements rule = 116 case rule of 117 INFIX (STD_infix(rules, _)) => map rule_left rules 118 | INFIX RESQUAN_OP => [ResquanOpTok] 119 | INFIX (FNAPP rules) => STD_HOL_TOK fnapp_special :: map rule_left rules 120 | INFIX VSCONS => [VS_cons] 121 | SUFFIX (STD_suffix rules) => map rule_left rules 122 | SUFFIX TYPE_annotation => [TypeColon] 123 | _ => [] 124 125datatype order_compat_verdict = OK | Multify of mx_order | Bad 126fun order_compat mx1 mx2 = 127 case (mx1, mx2) of 128 (PM_LESS src1, PM_LESS src2) => if src1 = src2 then OK 129 else Multify (PM_LESS MS_Multi) 130 | (PM_GREATER src1, PM_GREATER src2) => if src1 = src2 then OK 131 else Multify (PM_GREATER MS_Multi) 132 | (PM_EQUAL, _) => OK 133 | (_, PM_EQUAL) => OK 134 | (PM_LG i1, PM_LG i2) => if i1 = i2 then OK else Bad 135 | (_ , _) => Bad 136 137fun mx_order mxo = 138 case mxo of 139 PM_LESS _ => SOME LESS 140 | PM_GREATER _ => SOME GREATER 141 | PM_EQUAL => SOME EQUAL 142 | PM_LG _ => NONE 143 144(* turn a rule element list into a list of std_hol_toks *) 145val rel_list_to_toklist = 146 List.mapPartial (fn TOK s => SOME (STD_HOL_TOK s) | _ => NONE) 147 148fun find_suffix_rhses (G : grammar) = let 149 fun select (SUFFIX TYPE_annotation) = [[TypeTok]] 150 | select (SUFFIX (STD_suffix rules)) = let 151 in 152 map (rel_list_to_toklist o rule_elements o #elements) rules 153 end 154 | select (CLOSEFIX rules) = 155 map (rel_list_to_toklist o rule_elements o #elements) rules 156 | select _ = [] 157 val suffix_rules = List.concat (map (select o #2) (rules G)) 158in 159 Id :: map List.last suffix_rules 160end 161 162fun find_prefix_lhses (G : grammar) = let 163 fun select x = let 164 in 165 case x of 166 PREFIX (STD_prefix rules) => 167 map (rel_list_to_toklist o rule_elements o #elements) rules 168 | CLOSEFIX rules => 169 map (rel_list_to_toklist o rule_elements o #elements) rules 170 | _ => [] 171 end 172 val prefix_rules = List.concat (map (select o #2) (rules G)) 173in 174 Id :: map STD_HOL_TOK (binders G) @ map hd prefix_rules 175end 176 177val ambigrm = ref 1 178val _ = Feedback.register_trace ("ambiguous grammar warning", ambigrm, 2) 179 180fun STtoString (G:grammar) x = 181 case x of 182 STD_HOL_TOK s => s 183 | BOS => "<beginning of input>" 184 | EOS => "<end of input>" 185 | VS_cons => "<gap between varstructs>" 186 | Id => "<identifier>" 187 | TypeColon => #type_intro (specials G) 188 | TypeTok => "<type>" 189 | EndBinding => #endbinding (specials G) ^ " (end binding)" 190 | ResquanOpTok => #res_quanop (specials G)^" (res quan operator)" 191 192fun mk_prec_matrix G = let 193 exception NotFound = Binarymap.NotFound 194 exception BadTokList 195 type dict = ((stack_terminal * bool) * stack_terminal, 196 mx_order) Binarymap.dict ref 197 val {lambda, endbinding, type_intro, restr_binders, ...} = specials G 198 val specs = grammar_tokens G 199 val Grules = term_grammar.grammar_rules G 200 val alltoks = 201 ResquanOpTok :: VS_cons :: STD_HOL_TOK fnapp_special :: all_tokens specs 202 val matrix: dict = 203 Polyhash.mkDict (pair_compare(pair_compare(ST_compare,bool_compare), 204 ST_compare)) 205 (* the bool is true if there is a non-terminal between the two 206 terminal tokens. E.g., 207 x + -y 208 doesn't have such a space between the + and -, whereas 209 x + z - y 210 does (the z will be a non-terminal) 211 *) 212 213 val rule_elements = term_grammar.rule_elements o #elements 214 val complained_this_iteration = ref false 215 fun insert_bail k = 216 (Polyhash.insert matrix (k, PM_LESS MS_Multi); 217 complained_this_iteration := true; 218 if not (!complained_already) andalso 219 (!Globals.interactive orelse !ambigrm = 2) 220 then let 221 val msg = "Grammar ambiguous on token pair "^ 222 STtoString G (#1 (#1 k)) ^ " and " ^ 223 STtoString G (#2 k) ^ ", and "^ 224 "probably others too" 225 in 226 case !ambigrm of 227 0 => () 228 | 1 => (Feedback.HOL_WARNING "Parse" "Term" msg; 229 complained_already := true) 230 | 2 => raise Feedback.mk_HOL_ERR "parse_term" "mk_prec_matrix" msg 231 | _ => raise Fail "parse_term: matrix construction invariant fail!" 232 end 233 else 234 ()) 235 fun insert k v = let 236 val insert_result = Polyhash.peekInsert matrix (k, v) 237 val raw_insert = Polyhash.insert matrix 238 in 239 case (insert_result, v) of 240 (SOME PM_EQUAL, _) => () (* ignore this *) 241 | (SOME _, PM_EQUAL) => raw_insert (k,v) (* EQUAL overrides *) 242 | (SOME oldv, _) => let 243 in 244 case order_compat oldv v of 245 OK => () 246 | Multify v' => raw_insert (k, v') 247 | Bad => let 248 nonfix << >> 249 val op >> = GREATER and op << = LESS 250 in 251 case (oldv,v) of 252 (PM_LESS src1, PM_GREATER src2) => let 253 in 254 case (src1, src2) of 255 (Ifx, Pfx) => raw_insert (k, PM_LG {ifx= <<, pfx= >>}) 256 | (Pfx, Ifx) => raw_insert (k, PM_LG {ifx= >>, pfx= <<}) 257 | _ => insert_bail k 258 end 259 | (PM_GREATER src1, PM_LESS src2) => let 260 in 261 case (src1, src2) of 262 (Ifx,Pfx) => raw_insert (k, PM_LG {ifx= >>, pfx= <<}) 263 | (Pfx,Ifx) => raw_insert (k, PM_LG {ifx= <<, pfx= >>}) 264 | _ => insert_bail k 265 end 266 | _ => insert_bail k 267 end 268 end 269 | (NONE, _) => () 270 end 271 fun insert_eqs rule = let 272 fun insert_eqn (tk1,intervening_tm,tk2) = 273 insert((STD_HOL_TOK tk1, intervening_tm), STD_HOL_TOK tk2) PM_EQUAL 274 val insert_eqns = app insert_eqn 275 val equalities = PrecAnalysis.rule_equalities 276 in 277 case rule of 278 PREFIX (STD_prefix rules) => app (insert_eqns o equalities) rules 279 | PREFIX (BINDER slist) => let 280 fun bindertok (BinderString {tok, ...}) = [tok] 281 | bindertok LAMBDA = lambda 282 val btoks = List.concat (map bindertok slist) 283 in 284 app (fn s => insert ((STD_HOL_TOK s, true), EndBinding) PM_EQUAL) btoks 285 end 286 | SUFFIX (STD_suffix rules) => app (insert_eqns o equalities) rules 287 | SUFFIX TYPE_annotation => () 288 | INFIX (STD_infix (rules, _)) => app (insert_eqns o equalities) rules 289 | INFIX RESQUAN_OP => () 290 | INFIX (FNAPP lst) => app (insert_eqns o equalities) lst 291 | INFIX VSCONS => () 292 | CLOSEFIX rules => app (insert_eqns o equalities) rules 293 end 294 295 fun bi_insert (t1,t2) order = (insert ((t1,false), t2) order; 296 insert ((t1,true), t2) order) 297 (* the right hand end of a suffix or a closefix is greater than 298 everything *) 299 val closed_rhses = find_suffix_rhses G 300 fun insert_rhs_relns () = let 301 val all = alltoks 302 val rhses = closed_rhses 303 in 304 app (fn rhs => app (fn t => bi_insert (rhs, t) (PM_GREATER MS_Other)) all) 305 rhses 306 end 307 308 (* everything not a suffix rhs is less than the left hand end of a 309 prefix/closefix *) 310 val closed_lhses = find_prefix_lhses G 311 fun insert_lhs_relns () = let 312 val all = alltoks -- (EOS::closed_rhses) 313 in 314 app (fn lhs => app (fn t => insert ((t,false), lhs) (PM_LESS MS_Other)) 315 all) 316 closed_lhses 317 end 318 fun map_rule f [] = [] 319 | map_rule f (x::xs) = let 320 val rest = map_rule f xs 321 val here = 322 case x of 323 INFIX (STD_infix (rules, _)) => map (f o rule_elements) rules 324 | INFIX (FNAPP rules) => map (f o rule_elements) rules 325 | SUFFIX (STD_suffix rules) => map (f o rule_elements) rules 326 | PREFIX (STD_prefix rules) => map (f o rule_elements) rules 327 | CLOSEFIX rules => map (f o rule_elements) rules 328 | _ => [] 329 in 330 here @ rest 331 end 332 val last_rtok = first_rtok o List.rev 333 val all_lhs = 334 TypeColon::BOS::VS_cons::ResquanOpTok::Id:: 335 map STD_HOL_TOK (fnapp_special::(map_rule first_rtok Grules)) 336 val all_rhs = 337 TypeTok::EndBinding::EOS::VS_cons::ResquanOpTok::Id:: 338 map STD_HOL_TOK (fnapp_special::(map_rule last_rtok Grules)) 339 (* Between things that are equal, the thing on the left is less than 340 all possible left hand sides, and the thing on the right is 341 greater than all possible right hand sides. *) 342 fun calc_eqpairs() = 343 List.mapPartial 344 (fn (((t1,_),t2), v) => if v = PM_EQUAL then SOME (t1,t2) else NONE) 345 (Polyhash.listItems matrix) 346 fun terms_between_equals (k1, k2) = let 347 in 348 app (fn lhs => bi_insert (k1, lhs) (PM_LESS MS_Other)) all_lhs; 349 app (fn rhs => bi_insert (rhs, k2) (PM_GREATER MS_Other)) all_rhs 350 end 351 352 (* now the tricky stuff where the precedence relation makes a difference *) 353 (* if the rule might grab stuff to its left (is an infix or suffix), 354 then add 355 x > rule's left hand token 356 for all x on right hand side of prefixes and infixes below 357 if the rule might grab stuff to its right (is an infix or prefix) 358 then add 359 rule's right hand token < x 360 for all x on left hand side of suffixes and infixes below *) 361 fun rule_right (rr:rule_record) = 362 case List.last (rule_elements rr) of 363 TOK s => STD_HOL_TOK s 364 | _ => raise Fail ("rule list is bogus for "^ #term_name rr) 365 fun add2 v p = (p,v) 366 fun right_grabbing_elements rule = 367 case rule of 368 INFIX(STD_infix(rules, _)) => map (add2 Ifx o rule_right) rules 369 | INFIX RESQUAN_OP => [(ResquanOpTok,Ifx)] 370 | INFIX(FNAPP rules) => 371 (STD_HOL_TOK fnapp_special,Ifx) :: map (add2 Ifx o rule_right) rules 372 | INFIX VSCONS => [(VS_cons,Ifx)] 373 | PREFIX (BINDER _) => [(EndBinding,Pfx)] 374 | PREFIX (STD_prefix rules) => map (add2 Pfx o rule_right) rules 375 | _ => [] 376 val GREATER' = PM_GREATER MS_Other 377 val LESS' = PM_LESS MS_Other 378 val EQUAL' = PM_EQUAL 379 fun process_rule rule remainder = 380 case rule of 381 INFIX(STD_infix(rules, assoc)) => let 382 val this_level_lefts = map rule_left rules 383 val lower_rights = List.concat (map right_grabbing_elements remainder) 384 val this_level_rights = map rule_right rules 385 val lower_lefts = List.concat (map left_grabbing_elements remainder) 386 (* for infix rules, also need to add precedence relations if there is 387 associativity *) 388 in 389 app (fn lefttok => 390 app 391 (fn (lower_right,src) => 392 insert ((lower_right,true), lefttok) (PM_GREATER src)) 393 lower_rights) 394 this_level_lefts; 395 app (fn righttok => 396 app 397 (fn lower_left => insert ((righttok,true), lower_left) 398 (PM_LESS Ifx)) 399 lower_lefts) 400 this_level_rights; 401 case assoc of 402 LEFT => let 403 in 404 app (fn right_tok => 405 app (fn left_tok => insert ((right_tok,true), left_tok) 406 (PM_GREATER Ifx)) 407 this_level_lefts) 408 this_level_rights 409 end 410 | RIGHT => let 411 in 412 app (fn right_tok => 413 app (fn left_tok => insert ((right_tok,true), left_tok) 414 (PM_LESS Ifx)) 415 this_level_lefts) 416 this_level_rights 417 end 418 | NONASSOC => () 419 end 420 | INFIX RESQUAN_OP => let 421 val lower_rights = List.concat (map right_grabbing_elements remainder) 422 val lower_lefts = List.concat (map left_grabbing_elements remainder) 423 in 424 app (fn lower_right => insert((#1 lower_right,true), ResquanOpTok) 425 GREATER') 426 lower_rights; 427 app (fn lower_left => insert((ResquanOpTok,true), lower_left) LESS') 428 lower_lefts 429 end 430 | PREFIX (STD_prefix rules) => let 431 val this_level_rights = map rule_right rules 432 val lower_lefts = List.concat (map left_grabbing_elements remainder) 433 in 434 app (fn right_tok => 435 app 436 (fn lower_left => insert ((right_tok,true), lower_left) 437 (PM_LESS Pfx)) 438 lower_lefts) 439 this_level_rights 440 end 441 | PREFIX (BINDER _) => let 442 val lower_lefts = List.concat (map left_grabbing_elements remainder) 443 in 444 app (fn lower_left => insert ((EndBinding,true),lower_left) LESS') 445 lower_lefts 446 end 447 | SUFFIX TYPE_annotation => let 448 val lower_rights = List.concat (map right_grabbing_elements remainder) 449 in 450 app (fn (lower_right,src) => 451 insert ((lower_right,true), TypeColon) (PM_GREATER src)) 452 lower_rights 453 end 454 | SUFFIX (STD_suffix rules) => let 455 val lower_rights = List.concat (map right_grabbing_elements remainder) 456 val lefts = map rule_left rules 457 in 458 app (fn left_tok => 459 app (fn (lower_right,src) => 460 insert ((lower_right,true), left_tok) (PM_GREATER src)) 461 lower_rights) 462 lefts 463 end 464 | INFIX (FNAPP rules) => let 465 val lower_rights = List.concat (map right_grabbing_elements remainder) 466 val lower_lefts = List.concat (map left_grabbing_elements remainder) 467 val this_level_lefts = map rule_left rules 468 val this_level_rights = map rule_right rules 469 val fnapp = STD_HOL_TOK fnapp_special 470 in 471 app (fn lower_left => insert ((fnapp,true), lower_left) LESS') 472 lower_lefts; 473 app (fn lower_right => insert ((#1 lower_right,true), fnapp) GREATER') 474 lower_rights; 475 (* function application left associative *) 476 insert ((fnapp,true), fnapp) GREATER'; 477 app (fn other => insert ((other,true), fnapp) GREATER') 478 this_level_rights; 479 app (fn other => insert ((fnapp,true), other) GREATER') 480 this_level_lefts; 481 process_rule (INFIX(STD_infix (rules, LEFT))) remainder 482 end 483 | INFIX VSCONS => let 484 val lower_rights = List.concat (map right_grabbing_elements remainder) 485 val lower_lefts = List.concat (map left_grabbing_elements remainder) 486 in 487 app (fn lower_left => insert ((VS_cons,true), lower_left) LESS') 488 lower_lefts; 489 app (fn lower_right => insert ((#1 lower_right,true), VS_cons) GREATER') 490 lower_rights; 491 (* kind of non-associative *) 492 insert ((VS_cons,true), VS_cons) EQUAL' 493 end 494 | _ => () 495 fun apply_them_all f [] = () 496 | apply_them_all f (x::xs) = (f x xs ; apply_them_all f xs) 497in 498 app insert_eqs Grules ; 499 insert ((BOS, true), EOS) EQUAL'; 500 app terms_between_equals (calc_eqpairs()); 501 (* these next equality pairs will never have terms interfering between 502 them, so we can insert the equality relation between them after doing 503 the above *) 504 insert ((TypeColon,false), TypeTok) EQUAL'; 505 app (fn b => insert ((STD_HOL_TOK b,true), EndBinding) EQUAL') (binders G); 506 insert_rhs_relns () ; 507 insert_lhs_relns () ; 508 apply_them_all process_rule Grules; 509 if (not (!complained_this_iteration)) then complained_already := false 510 else (); 511 matrix 512end 513 514(* string is name of term; list of pairs, is list of token-pairs between 515 which a list style reduction is required *) 516type mini_lspec = {cons:string,nilstr:string,sep:string} 517datatype rsfixity = rsInfix | rsPrefix | rsClosefix | rsSuffix 518datatype rule_summary = 519 RealRule of rsfixity * string 520 (* keyed on, e.g., [TOK "let"; TM; TOK "in"; TM] *) 521 | ListOnly of mini_lspec 522 (* for lists that appear between tokens that are only a part of 523 the rule. E.g., keyed on [TOK "let"; TOK "in"] *) 524 525fun summary_toString rs = 526 case rs of 527 RealRule (_, s) => s 528 | ListOnly {cons,nilstr=n,...} => "List : {cons = "^cons^", nil = "^n^"}" 529 530 531(* in addition to all of the rules that you'd expect due to the infix, 532 prefix, suffix and closefix operators, we also add rules for the 533 nil singleton, and doubleton cases of the list rules. This 534 increases efficiency for these relatively common cases, saving us 535 an examination of the grammar when we come to do a reduction to 536 spot whether a putative rhs is an instance of a list *) 537 538fun listTM_delimiters rels = 539 case rels of 540 [] => [] 541 | [_] => [] 542 | TOK tk1 :: ListTM lsp :: (rest as (TOK tk2 :: _)) => 543 ([TOK tk1,TOK tk2], ListOnly lsp) :: listTM_delimiters rest 544 | (_ :: rest) => listTM_delimiters rest 545 546fun de_listTM rels = map (fn ListTM _ => TM | x => x) rels 547 548fun infix_rule (rels, nm) = 549 (mkrels_infix (de_listTM rels), RealRule(rsInfix, nm)) 550fun prefix_rule (rels,nm) = 551 (mkrels_prefix (de_listTM rels), RealRule(rsPrefix, nm)) 552fun closefix_rule (rels,nm) = 553 (mkrels_closefix (de_listTM rels), RealRule(rsClosefix, nm)) 554fun suffix_rule (rels,nm) = 555 (mkrels_suffix (de_listTM rels), RealRule(rsSuffix, nm)) 556 557fun mk_ruledb (G:grammar) = let 558 val Grules = term_grammar.grammar_rules G 559 val table:(rule_element list, rule_summary)Binarymap.dict ref = 560 Polyhash.mkDict (Lib.list_compare RE_compare) 561 fun insert_rule mkfix (rr:rule_record) = 562 let 563 val rels = term_grammar.rule_elements (#elements rr) 564 val nm = #term_name rr 565 in 566 (Polyhash.insert table (mkfix (rels,nm)); 567 List.app (Polyhash.insert table) (listTM_delimiters rels)) 568 end 569 fun addrule rule = 570 case rule of 571 INFIX (STD_infix(rules, _)) => app (insert_rule infix_rule) rules 572 | INFIX RESQUAN_OP => () 573 | INFIX VSCONS => () 574 | INFIX (FNAPP rules) => let 575 in 576 Polyhash.insert table (mkrels_infix [TOK fnapp_special], 577 RealRule(rsInfix, fnapp_special)); 578 app (insert_rule infix_rule) rules 579 end 580 | PREFIX (STD_prefix rules) => 581 app (insert_rule prefix_rule) rules 582 | PREFIX (BINDER s) => () 583 | SUFFIX (STD_suffix rules) => 584 app (insert_rule suffix_rule) rules 585 | SUFFIX TYPE_annotation => () 586 | CLOSEFIX rules => app (insert_rule closefix_rule) rules 587in 588 app addrule Grules; 589 table 590end 591 592 593fun mwhile B C = 594 B >- (fn b => if b then C >> mwhile B C else ok) 595 596fun mif B C = B >- (fn b => if b then C else ok) 597 598datatype 'a stack_item = 599 Terminal of stack_terminal | 600 NonTerminal of 'a preterm | 601 NonTermVS of 'a varstruct locn.located list 602 603fun is_terminal (Terminal _,_) = true 604 | is_terminal _ = false 605fun dest_terminal (Terminal x,_) = x 606 | dest_terminal _ = raise Fail "dest_terminal not called on terminal" 607fun is_nonterm t = not (is_terminal t) 608 609 610datatype 'a lookahead_item = 611 Token of 'a term_token | PreType of Pretype.pretype | 612 LA_Symbol of stack_terminal 613 614datatype vsres_state = VSRES_Normal | VSRES_VS | VSRES_RESTM 615 616datatype 'a PStack = 617 PStack of {stack : ('a stack_item locn.located * 'a lookahead_item) list, 618 lookahead : 'a lookahead_item locn.located list, 619 in_vstruct : (vsres_state * int) list} 620 621(* dummy lookahead token *) 622val XXX = Token (Ident "XXX") 623 624 625fun pstack (PStack {stack, ...}) = stack 626fun upd_stack (PStack {stack, lookahead, in_vstruct}) new = 627 PStack{stack = new, lookahead = lookahead, in_vstruct = in_vstruct} 628fun pla (PStack{lookahead,...}) = lookahead 629fun upd_la (PStack {stack, lookahead, in_vstruct}) new = 630 PStack{stack = stack, lookahead = new, in_vstruct = in_vstruct} 631fun invstructp0 (PStack{in_vstruct,...}) = in_vstruct 632 633fun fupd_hd f [] = [] 634 | fupd_hd f (x::xs) = f x :: xs 635 636fun fupd_fst f (x,y) = (f x, y) 637fun fupd_snd f (x,y) = (x, f y) 638 639fun fupd_vs0 f (PStack{in_vstruct,lookahead,stack}) = 640 PStack{stack = stack, lookahead = lookahead, in_vstruct = f in_vstruct} 641 642fun invstructp (cs, p) = Some ((cs, p), invstructp0 p) 643 644fun inc_paren (cs, p) = 645 Some ((cs, fupd_vs0 (fupd_hd (fupd_snd (fn n => n + 1))) p), ()) 646fun dec_paren (cs, p) = 647 Some ((cs, fupd_vs0 (fupd_hd (fupd_snd (fn n => n - 1))) p), ()) 648fun enter_binder (cs,p) = 649 Some ((cs, fupd_vs0 (fn rest => (VSRES_VS, 0)::rest) p), ()) 650fun enter_restm (cs, p) = 651 Some ((cs, fupd_vs0 (fupd_hd (fupd_fst (K VSRES_RESTM))) p), ()) 652fun leave_restm (cs, p) = 653 Some ((cs, fupd_vs0 (fupd_hd (fupd_fst (K VSRES_VS))) p), ()) 654fun leave_binder (cs, p) = Some ((cs, fupd_vs0 tl p), ()) 655 656fun push_pstack p i = upd_stack p (i::pstack p) 657fun top_pstack p = hd (pstack p) 658fun pop_pstack p = upd_stack p (tl (pstack p)) 659 660fun push t (cs, p) = Some ((cs, push_pstack p t), ()) 661fun topterm (cs, p) = 662 case List.find (is_terminal o #1) (pstack p) of 663 NONE => Error (noloc "No terminal in stack") 664 | SOME x => Some((cs,p), x) 665fun pop (cs, p) = 666 Some ((cs, pop_pstack p), top_pstack p) 667 handle Empty => Error (noloc "pop: empty stack") 668fun getstack (cs, p) = Some ((cs, p), pstack p) 669 670 671fun set_la tt (cs, p) = Some ((cs, upd_la p tt), ()) 672fun current_la (cs, p) = Some ((cs, p), pla p) 673 674fun findpos P [] = NONE 675 | findpos P (x::xs) = if P x then SOME(0,x) 676 else Option.map (fn (n,x) => (n + 1, x)) (findpos P xs) 677 678fun get_case_info (G : grammar) = let 679 fun extract_tok(ppel,acc) = 680 case ppel of 681 RE (TOK s) => s :: acc 682 | PPBlock (ppels, _) => List.foldl extract_tok acc ppels 683 | _ => acc 684 fun extract_toks ppels = List.rev (List.foldl extract_tok [] ppels) 685 fun rr_foldthis ({term_name,elements,...}, acc) = 686 if GrammarSpecials.is_case_special term_name then 687 case Binarymap.peek(acc, term_name) of 688 NONE => Binarymap.insert(acc, term_name, [extract_toks elements]) 689 | SOME els => 690 Binarymap.insert(acc, term_name, extract_toks elements :: els) 691 else acc 692 fun foldthis (gr, acc) = 693 case gr of 694 PREFIX (STD_prefix rrs) => List.foldl rr_foldthis acc rrs 695 | _ => acc 696 val candidates = 697 List.foldl foldthis (Binarymap.mkDict String.compare) (grammar_rules G) 698 val error_case = {casebar = NONE, casecase = NONE, caseof = NONE} 699 fun mapthis (cspecial, candidates) = 700 case Listsort.sort (flip_cmp (measure_cmp length)) candidates of 701 [] => error_case 702 | toks :: _ => 703 let 704 in 705 if length toks <> 4 orelse last toks <> last (butlast toks) then 706 error_case 707 else {casebar = SOME (last toks), casecase = SOME (hd toks), 708 caseof = SOME (hd (tl toks))} 709 end 710 val specials_to_toks = Binarymap.map mapthis candidates 711 val toks_to_specials = let 712 fun foldthis (k,r,acc) = 713 case #casecase r of 714 NONE => acc 715 | SOME tok => 716 (case Binarymap.peek(acc,tok) of 717 NONE => Binarymap.insert(acc,tok,k) 718 | SOME k' => raise Fail ("Tok \"" ^ tok ^ 719 "\" maps to case specials " ^ 720 valOf (dest_case_special k) ^ " and " ^ 721 valOf (dest_case_special k'))) 722 in 723 Binarymap.foldl foldthis (Binarymap.mkDict String.compare) specials_to_toks 724 end 725in 726 (specials_to_toks, toks_to_specials) 727end 728 729fun parse_term (G : grammar) (typeparser : term qbuf -> Pretype.pretype) = let 730 val Grules = grammar_rules G 731 val {type_intro, lambda, endbinding, restr_binders, res_quanop} = specials G 732 val num_info = numeral_info G 733 val overload_info = overload_info G 734 val (casespec_to_tok, casetok_to_spec) = get_case_info G 735 val closed_lefts = find_prefix_lhses G 736 val left_grabbers = List.concat (map left_grabbing_elements Grules) 737 val fnapp_closed_lefts = Lib.subtract closed_lefts left_grabbers 738 val _ = 739 isSome (findpos (fn (SUFFIX TYPE_annotation) => true | _ => false) 740 Grules) 741 orelse raise Fail "Grammar must allow type annotation" 742 val prec_matrix = mk_prec_matrix G 743 val rule_db = mk_ruledb G 744 val is_binder = is_binder G 745 val binder_table = let 746 fun recurse (r, acc) = 747 case r of 748 PREFIX (BINDER blist) => let 749 fun irec (b, acc) = 750 case b of 751 LAMBDA => acc 752 | BinderString {term_name, tok, ...} => 753 Binarymap.insert(acc,tok,term_name) 754 in 755 List.foldl irec acc blist 756 end 757 | _ => acc 758 in 759 List.foldl recurse (Binarymap.mkDict String.compare) Grules 760 end 761 fun term_name_for_binder s = Binarymap.find(binder_table,s) 762 val grammar_tokens = term_grammar.grammar_tokens G 763 val lex = let 764 val specials = endbinding::grammar_tokens @ term_grammar.known_constants G 765 val ttlex = term_tokens.lex specials 766 in 767 fn (qb, ps) => 768 case ttlex qb of 769 NONE => Error (noloc "Token-lexing failed") 770 | SOME t => Some ((qb, ps), t) 771 end 772 fun lifted_typeparser (qb, ps) = Some ((qb, ps), typeparser qb) 773 774 775 val keyword_table = 776 HOLset.addList(HOLset.empty String.compare, grammar_tokens) 777 778 (* transform takes an input token (of the sort that comes out of the 779 lexer), and turns it into a token of the sort used internally by the 780 parser. *) 781 fun transform (in_vs as (vs_state, nparens)) 782 (t:'a lookahead_item locn.located option) = 783 case t of 784 NONE => (EOS, locn.Loc_None, NONE) 785 | SOME (tt as Token x,locn) => let 786 in 787 case x of 788 Ident s => 789 if String.sub(s,0) = #"$" andalso 790 CharVector.exists (not o equal #"$") s 791 then 792 let 793 val locn = locn.move_start 1 locn 794 in 795 (Id, locn, SOME (Token (Ident (String.extract(s,1,NONE))))) 796 end 797 else if s = res_quanop andalso vs_state = VSRES_VS then 798 (ResquanOpTok, locn, SOME tt) 799 else if s = type_intro then (TypeColon, locn, SOME tt) 800 else if s = vs_cons_special then (VS_cons, locn, SOME tt) 801 else if s = endbinding andalso nparens = 0 andalso 802 vs_state <> VSRES_Normal then (EndBinding, locn, SOME tt) 803 else if HOLset.member(keyword_table, s) then 804 (STD_HOL_TOK s, locn, SOME tt) 805 else (Id, locn, SOME tt) 806 | Antiquote _ => (Id, locn, SOME tt) 807 | Numeral _ => (Id, locn, SOME tt) 808 | Fraction _ => (Id, locn, SOME tt) 809 | QIdent _ => (Id, locn, SOME tt) 810 end 811 | SOME (tt as PreType ty,locn) => (TypeTok, locn, SOME tt) 812 | SOME (tt as LA_Symbol st,locn) => (st, locn, SOME tt) 813 814 (* find the initial segment of the stack such that all of the segment 815 has the equality relation between components and such that the first 816 element not in the segment is less than than the last one in the 817 segment *) 818 (* NB: the FAILloc invocations in this function raise Failloc exceptions that 819 are trapped at the bottom of the perform_reduction function *) 820 fun find_reduction stack = 821 case stack of 822 [] => raise Fail "find_reduction: stack empty!" 823 | [_] => raise Fail "find_reduction: stack singleton!" 824 | ((t1 as ((Terminal x1,x1locn), _))::rest) => let 825 in 826 case rest of 827 [] => FAILloc x1locn "find_reduction : impossible" 828 | (((Terminal x2,x2locn), _)::_) => let 829 val res = valOf (Polyhash.peek prec_matrix ((x2,false),x1)) 830 handle Option => 831 FAILloc (locn.between x2locn x1locn) 832 ("No relation between "^STtoString G x2^" and "^ 833 STtoString G x1) 834 in 835 case res of 836 PM_LESS _ => [t1] 837 | PM_EQUAL => (t1::find_reduction rest) 838 | PM_LG _ => [t1] 839 (* must be a less, because a greater is impossible *) 840 | PM_GREATER _ => FAILloc (locn.between x2locn x1locn) 841 "find_reduction: found a greater on stack" 842 end 843 | ((t2 as ((_,t2locn),_))::rest2) => let 844 (* t2 is a non-terminal, whether VS or not *) 845 in 846 case rest2 of 847 [] => FAILloc t2locn "find_reduction : nonterminal at stack base!" 848 | (((Terminal x2,x2locn), _)::_) => let 849 val res = valOf (Polyhash.peek prec_matrix ((x2,true), x1)) 850 handle Option => 851 FAILloc (locn.between x2locn t2locn) 852 ("No relation between "^STtoString G x2^" and "^ 853 STtoString G x1) 854 in 855 case res of 856 PM_LESS _ => [t1,t2] 857 | PM_EQUAL => t1::t2::find_reduction rest2 858 | PM_LG _ => [t1,t2] 859 | PM_GREATER _ => FAILloc (locn.between x2locn t2locn) 860 "find_reduction: greater on stack!" 861 end 862 | (((_,locn),_)::_) => FAILloc (locn.between locn t2locn) "find_reduction 2 NTs!" 863 end 864 end 865 | (t1::rest) => t1::find_reduction rest (* t1 a non-terminal *) 866 867 (* given an initial segment of the stack that corresponds to a reduction, 868 determine whether or not this corresponds to a rule, and if it does 869 pull the tokens of the stack and replace them with the right 870 non-terminal *) 871 fun perform_reduction rhs = let 872 fun ok_item ((Terminal (STD_HOL_TOK _),_), _) = true 873 | ok_item ((NonTerminal _,_), _) = true 874 | ok_item _ = false 875 876 (* If the RHS is for a list, then what follows is only called on what 877 will be list RHSes of length greater than two, as smaller lists will 878 have been caught by the insertion of these rules specifically into 879 the DB. *) 880 datatype rule_possibility = Normal of (rsfixity * string) 881 | CaseRule of string 882 883 fun handle_case_reduction lrlocn pattern = let 884 val errmsg = "No rule for "^ listtoString reltoString pattern 885 fun fail() = FAILloc lrlocn errmsg 886 fun badcase() = FAILloc lrlocn "Mal-formed case expression" 887 fun tokstring x = case x of TOK s => SOME s | _ => NONE 888 val poss_left = case hd pattern of TOK x => x | _ => fail() 889 in 890 case Binarymap.peek(casetok_to_spec, poss_left) of 891 SOME cspec => 892 let 893 val {casecase,casebar,caseof} = 894 Binarymap.find(casespec_to_tok,cspec) 895 fun bars_ok l = 896 case l of 897 [TM] => true 898 | TM :: TOK s :: rest => SOME s = casebar andalso bars_ok rest 899 | _ => false 900 fun case_ok l = 901 case l of 902 TM :: TOK ofs :: TOK s :: rest => 903 let 904 in 905 SOME ofs = caseof andalso SOME s = casebar andalso 906 bars_ok rest 907 end 908 | TM :: TOK ofs :: rest => SOME ofs = caseof andalso 909 bars_ok rest 910 | _ => false 911 in 912 if case_ok (tl pattern) then CaseRule cspec else badcase() 913 end 914 | NONE => fail() 915 end 916 fun checkcase r = 917 case r of 918 RealRule (r0 as (fx, s)) => 919 if fx = rsPrefix andalso GrammarSpecials.is_case_special s then 920 CaseRule s 921 else Normal r0 922 | ListOnly _ => raise Fail "checkcase: found ListOnly" 923 in 924 if List.all ok_item rhs then let 925 (* it's important to remember that the left end of the possible 926 RHS might have looked like TOK s1 -- TM -- TOK s2, and that 927 in this case there will be s1 < s2 in the precedence matrix, but 928 that TM will always have been popped in this case. 929 930 This may or may not be appropriate. If the RHS is a suffix thing 931 or an infix, then that TM is part of the reduction, otherwise it 932 isn't, and should be left on the stack. 933 934 Below, the variable top_was_tm is true if a TM was popped in this 935 way. *) 936 (* NB: terminology: each stack item is either a TM (=term, i.e., 937 nonterminal) or a TOK (=token, i.e., terminal). *) 938 fun stack_item_to_rule_element (Terminal (STD_HOL_TOK s),_) = TOK s 939 | stack_item_to_rule_element (NonTerminal _,_) = TM 940 | stack_item_to_rule_element (_,locn) = 941 FAILloc locn "perform_reduction: gak!" 942 val ((_,rlocn),_) = List.hd rhs 943 val rhs = List.rev rhs 944 val translated_rhs = map (stack_item_to_rule_element o #1) rhs 945 val ((_,llocn),_) = List.hd rhs 946 val lrlocn = locn.between llocn rlocn 947 val top_was_tm = hd translated_rhs = TM 948 fun lrcheck (s1,s2) = 949 case Polyhash.peek rule_db [TOK s1, TOK s2] of 950 SOME (ListOnly lsp) => SOME lsp 951 | _ => NONE 952 val listredns = check_for_listreductions lrcheck translated_rhs 953 val (listfixed_rhs, lspinfo) = 954 remove_listrels listredns translated_rhs 955 val rule = 956 case Polyhash.peek rule_db listfixed_rhs of 957 NONE => 958 if top_was_tm then 959 let 960 val drop1 = tl listfixed_rhs 961 in 962 case Polyhash.peek rule_db drop1 of 963 NONE => handle_case_reduction lrlocn drop1 964 | SOME r => checkcase r 965 end 966 else 967 handle_case_reduction lrlocn listfixed_rhs 968 | SOME r => checkcase r 969 val ignore_top_item = 970 case rule of 971 Normal (rsInfix, _) => false 972 | Normal (rsSuffix, _) => false 973 | _ => top_was_tm 974 (* rhs' is the actual stack segment matched by the rule, and llocn' is 975 its left edge, unlike rhs and llocn which may contain a spurious TM 976 on the left *) 977 val rhs' = if ignore_top_item then tl rhs else rhs 978 val ((_,llocn'),_) = List.hd rhs' 979 val lrlocn' = locn.between llocn' rlocn 980 fun seglocs xs als mal = 981 (* extract TM items, and locations of right edges of 982 maximal initial segments containing them *) 983 case (xs,mal) of 984 ((((NonTerminal p,locn),_)::xs), NONE) => 985 seglocs xs als (SOME((p,locn),locn)) 986 | ((((NonTerminal p,locn),_)::xs), SOME al) => 987 seglocs xs (al::als) (SOME((p,locn),locn)) 988 | ((((_ ,locn),_)::xs), NONE ) => seglocs xs als mal 989 | ((((_ ,locn),_)::xs), SOME (pl,_)) => 990 seglocs xs als (SOME(pl,locn)) 991 | ([], NONE) => List.rev als 992 | ([], SOME al) => List.rev (al::als) 993 val args_w_seglocs0 = seglocs rhs' [] NONE 994 fun CCOMB((x,locn),y) = (COMB(y,x),locn.between (#2 y) locn) 995 fun process_lspinfos A i lspis args = 996 case lspis of 997 [] => List.revAppend(A,args) 998 | ({cons,nilstr,...}, is) :: more_lsps => 999 let 1000 fun mk_list [] = ((VAR nilstr,rlocn), rlocn) 1001 | mk_list ((lpt,l)::xs) = 1002 let 1003 val (ptl, locn) = mk_list xs 1004 in 1005 ((COMB((COMB((VAR cons,#2 lpt), lpt), #2 lpt), 1006 ptl), locn), 1007 locn.between (#2 lpt) rlocn) 1008 end 1009 in 1010 case is of 1011 [] => process_lspinfos (mk_list []::A) i more_lsps args 1012 | i1 :: _ => 1013 if i1 = i then 1014 let 1015 val (listtms, rest) = Lib.split_after (length is) args 1016 in 1017 process_lspinfos (mk_list listtms :: A) (i + length is) 1018 more_lsps 1019 rest 1020 end 1021 else 1022 process_lspinfos (hd args :: A) (i + 1) lspis (tl args) 1023 end 1024 val args_w_seglocs = process_lspinfos [] 0 lspinfo args_w_seglocs0 1025 val newterm = 1026 case rule of 1027 Normal (_, s) => 1028 if term_name_is_lform s then 1029 if length args_w_seglocs <> 1 then 1030 raise Fail 1031 "seglocs extraction: rule with more than one TM" 1032 else #1 (hd (args_w_seglocs)) 1033 else List.foldl CCOMB (VAR s,llocn') args_w_seglocs 1034 | CaseRule cs => let 1035 fun mkcase1 ((t,loc),_) = (COMB((VAR cs, loc), (t,loc)), loc) 1036 fun mkbar(((t,loc),_),acc) = 1037 (COMB((COMB((QIDENT("bool", 1038 GrammarSpecials.case_split_special), 1039 loc), 1040 (t,loc)), 1041 loc), 1042 acc), 1043 locn.between loc rlocn) 1044 in 1045 (COMB(mkcase1 (hd args_w_seglocs), 1046 List.foldr mkbar 1047 (#1 (last (tl args_w_seglocs))) 1048 (butlast (tl args_w_seglocs))), 1049 lrlocn) 1050 end 1051 in 1052 repeatn (length rhs') pop >> 1053 push ((NonTerminal (#1 newterm),lrlocn'), XXX) 1054 (* lrlocn: force location to entire RHS, including tokens *) 1055 end 1056 else 1057 case rhs of 1058 (((Terminal Id,locn), tt as Token (Antiquote a))::_) => let 1059 in 1060 pop >> invstructp >- 1061 (fn inv => 1062 if #1 (hd inv) = VSRES_VS then 1063 push ((NonTermVS [(VS_AQ a,locn)],locn), tt) 1064 else 1065 push ((NonTerminal (AQ a),locn), tt)) 1066 end 1067 | (((Terminal Id,locn), Token tt)::_) => let 1068 exception Temp of string 1069 val mk_numeral = 1070 Literal.gen_mk_numeral 1071 {mk_comb = fn (x,y) => (COMB(x,y),locn), 1072 ZERO = (QIDENT ("num" , "0" ),locn), 1073 ALT_ZERO = (QIDENT ("arithmetic", "ZERO" ),locn), 1074 NUMERAL = (QIDENT ("arithmetic", "NUMERAL"),locn), 1075 BIT1 = (QIDENT ("arithmetic", "BIT1") ,locn), 1076 BIT2 = (QIDENT ("arithmetic", "BIT2") ,locn)} 1077 fun inject_np NONE t = t 1078 | inject_np (SOME s) t = (COMB((VAR s,locn), t),locn) 1079 in 1080 pop >> invstructp >- 1081 (fn inv => let 1082 val thing_to_push = 1083 case (#1 (hd inv), tt) of 1084 (VSRES_VS, Numeral _) => let 1085 in 1086 raise Temp "can't have numerals in binding positions" 1087 end 1088 | (VSRES_VS, Fraction _) => let 1089 in 1090 raise Temp "can't have fractions in binding positions" 1091 end 1092 | (_, Fraction{wholepart,fracpart,places}) => let 1093 val _ = not (null num_info) orelse 1094 raise Temp "No fractions/numerals allowed" 1095 val ten = Arbnum.fromInt 10 1096 val denominator = Arbnum.pow(ten, Arbnum.fromInt places) 1097 val numerator = 1098 Arbnum.+(Arbnum.*(denominator,wholepart), 1099 fracpart) 1100 val mknum = inject_np (SOME fromNum_str) o mk_numeral 1101 in 1102 liftlocn NonTerminal 1103 (COMB((COMB((VAR decimal_fraction_special, 1104 locn.Loc_None), 1105 mknum numerator), locn.Loc_None), 1106 mknum denominator), 1107 locn) 1108 end 1109 | (_, Numeral(dp, copt)) => let 1110 val numeral_part = mk_numeral dp 1111 in 1112 case copt of 1113 SOME c => let 1114 val injector = 1115 List.find (fn (k,v) => k = c) num_info 1116 in 1117 case injector of 1118 NONE => let 1119 in 1120 raise Temp ("Invalid suffix " ^ str c ^ 1121 " for numeral") 1122 end 1123 | SOME (_, strop) => 1124 liftlocn NonTerminal 1125 (inject_np strop numeral_part) 1126 end 1127 | NONE => 1128 if null num_info then 1129 if dp = Arbnum.zero then 1130 (WARN "term_parser" 1131 ("\n 0 treated specially and allowed - "^ 1132 "no other numerals permitted"); 1133 liftlocn NonTerminal 1134 (inject_np NONE numeral_part)) 1135 else 1136 raise Temp "No numerals currently allowed" 1137 else let 1138 val fns = fromNum_str 1139 in 1140 if Overload.is_overloaded overload_info fns then 1141 liftlocn NonTerminal 1142 (inject_np (SOME fns) numeral_part) 1143 else 1144 raise Temp ("No overloadings exist for "^fns^ 1145 ": use character suffix for \ 1146 \numerals") 1147 (* NonTerminal (inject_np (#2 (hd num_info))) *) 1148 end 1149 end 1150 | (VSRES_VS, _) => 1151 (NonTermVS [(SIMPLE (token_string tt),locn)],locn) 1152 | (_, QIdent x) => (NonTerminal (QIDENT x),locn) 1153 | _ => (NonTerminal (VAR (token_string tt)),locn) 1154 (* tt is not an antiquote because of the wider context; 1155 antiquotes are dealt with in the wider case statement 1156 above *) 1157 in 1158 push (thing_to_push, Token tt) 1159 end handle Temp s => (WARNloc "parse_term" locn s; 1160 error (WARNloc_string locn s))) 1161 end 1162 | (((Terminal TypeTok,rlocn), PreType ty)::((Terminal TypeColon,_), _):: 1163 ((NonTerminal t,llocn), _)::rest) => let 1164 in 1165 repeatn 3 pop >> 1166 push ((NonTerminal (TYPED ((t,llocn), (ty,rlocn))), 1167 locn.between llocn rlocn), 1168 XXX) 1169 end 1170 | (((Terminal TypeTok,rlocn), PreType ty)::((Terminal TypeColon,_), _):: 1171 ((NonTermVS vsl,llocn), _)::rest) => let 1172 in 1173 repeatn 3 pop >> 1174 push ((NonTermVS 1175 (map (fn (v as (_,locn)) => (TYPEDV(v,(ty,rlocn)),locn)) 1176 vsl), 1177 locn.between llocn rlocn), 1178 XXX) 1179 end 1180 | [((Terminal TypeTok,rlocn), PreType ty), ((Terminal TypeColon,_), _)] => 1181 let 1182 val nonterm0 = (QIDENT("bool", "the_value"), rlocn) 1183 val type_annotation = 1184 (Pretype.Tyop{Thy="bool", Tyop = "itself", Args = [ty]}, 1185 rlocn) 1186 in 1187 pop >> pop >> 1188 push ((NonTerminal (TYPED(nonterm0, type_annotation)), rlocn), XXX) 1189 end 1190 | (((NonTerminal t,rlocn), _)::((Terminal EndBinding,_), _):: 1191 ((NonTermVS vsl,_), _)::((Terminal (STD_HOL_TOK binder),llocn), _):: 1192 rest) => let 1193 exception Urk of string 1194 in 1195 let 1196 fun has_resq (v,_) = 1197 case v of 1198 VPAIR(v1, v2) => has_resq v1 orelse has_resq v2 1199 | TYPEDV(v0, ty) => has_resq v0 1200 | RESTYPEDV _ => true 1201 | _ => false 1202 fun has_tupled_resq (VPAIR(v1, v2),_) = 1203 has_resq v1 orelse has_resq v2 1204 | has_tupled_resq (TYPEDV(v0, _),_) = has_tupled_resq v0 1205 | has_tupled_resq (RESTYPEDV(v0, _),_) = has_tupled_resq v0 1206 | has_tupled_resq _ = false 1207 fun ERROR s1 s2 = Urk (s1^": "^s2) 1208 fun extract_resq (v,_) = 1209 case v of 1210 TYPEDV (v0, _) => extract_resq v0 1211 | RESTYPEDV(v0, t) => let 1212 val sub_resq = extract_resq v0 1213 in 1214 case sub_resq of 1215 NONE => SOME(v0, t) 1216 | SOME _ => 1217 raise ERROR "parse_term" 1218 "Can't have double restricted quantification" 1219 end 1220 | _ => NONE 1221 fun comb_abs_fn(v,t) = let 1222 val binder = term_name_for_binder binder 1223 in 1224 if has_tupled_resq v then 1225 raise ERROR "parse_term" 1226 "Can't have restricted quantification on nested \ 1227 \arguments" 1228 else 1229 case extract_resq v of 1230 NONE => (COMB((VAR binder,llocn), 1231 (ABS(v, t),locn.between (#2 v) (#2 t))), 1232 locn.between llocn rlocn) 1233 | SOME (v',P) => let 1234 in 1235 (COMB((COMB((VAR (Lib.assoc (SOME binder) restr_binders), 1236 llocn), 1237 P),locn.between llocn (#2 P)), 1238 (ABS(v', t),locn.between (#2 v') (#2 t))), 1239 locn.between llocn rlocn) 1240 handle Feedback.HOL_ERR _ => 1241 raise ERROR "parse_term" 1242 ("No restricted quantifier associated \ 1243 \with " ^binder) 1244 end 1245 end 1246 fun abs_fn (v,t) = 1247 if has_tupled_resq v then 1248 raise ERROR "parse_term" 1249 "Can't have restricted quantification on \ 1250 \nested arguments" 1251 else 1252 case extract_resq v of 1253 NONE => (ABS(v,t),locn.between llocn rlocn) 1254 | SOME(v', P) => 1255 (COMB((COMB((VAR (Lib.assoc NONE restr_binders),llocn), 1256 P), locn.between llocn (#2 P)), 1257 (ABS(v', t),locn.between (#2 v') (#2 t))), 1258 locn.between llocn rlocn) 1259 handle Feedback.HOL_ERR _ => 1260 raise ERROR "parse_term" 1261 "No restricted quantifier associated \ 1262 \with lambda" 1263 val vsl = List.rev vsl 1264 val abs_t = 1265 List.foldr (if mem binder lambda then abs_fn else comb_abs_fn) 1266 (t,rlocn) vsl 1267 in 1268 repeatn 4 pop >> push (liftlocn NonTerminal abs_t, XXX) 1269 end handle Urk s => 1270 (WARNloc "parse_term" (locn.between llocn rlocn) s; 1271 error (WARNloc_string (locn.between llocn rlocn) s)) 1272 end 1273 | (((Terminal(STD_HOL_TOK ")"),rlocn), _)::(vsl as ((NonTermVS _,_),_)):: 1274 ((Terminal(STD_HOL_TOK "("),llocn), _)::rest) => let 1275 in 1276 (* need a rule here because 1277 1. a NonTermVS makes this a non-standard rule; and 1278 2. bracket-removal in the remove_specials code won't see 1279 the parentheses in the binding "var-struct" position 1280 *) 1281 repeatn 3 pop >> 1282 push vsl (* don't bother expanding locn; would add no useful info *) 1283 end 1284 | (((NonTermVS vsl1,rlocn), _)::((Terminal(STD_HOL_TOK ","),_), _):: 1285 ((NonTermVS vsl2,llocn), _)::rest) => let 1286 val lrlocn = locn.between llocn rlocn 1287 in 1288 if length vsl1 <> 1 orelse length vsl2 <> 1 then let 1289 val msg = "Can't have lists of atoms as arguments to , in binder" 1290 in 1291 (WARNloc "parse_term" lrlocn msg; 1292 error (WARNloc_string lrlocn msg)) 1293 end 1294 else 1295 repeatn 3 pop >> 1296 push ((NonTermVS [(VPAIR(hd vsl2, hd vsl1),lrlocn)],lrlocn), XXX) 1297 end 1298 | (((NonTerminal t,rlocn), _)::((Terminal ResquanOpTok,_), _):: 1299 ((NonTermVS vsl,llocn), _)::rest) => let 1300 in 1301 repeatn 3 pop >> 1302 push ((NonTermVS 1303 (map (fn (v as (_,locn))=> 1304 (RESTYPEDV(v,(t,rlocn)),locn)) vsl), 1305 locn.between llocn rlocn), 1306 XXX) >> 1307 leave_restm 1308 end 1309 | _ => let 1310 fun is_vcons_list [] = false 1311 | is_vcons_list [x] = false 1312 | is_vcons_list (((NonTermVS _,_), _)::((Terminal VS_cons,_), _)::rest) = let 1313 in 1314 case rest of 1315 [((NonTermVS _,_),_)] => true 1316 | _ => is_vcons_list rest 1317 end 1318 | is_vcons_list _ = false 1319 fun get_vsls ((NonTermVS vsl,_), _) = SOME vsl | get_vsls _ = NONE 1320 val ((_,rlocn),_) = List.hd rhs 1321 val ((_,llocn),_) = List.last rhs 1322 val lrlocn = locn.between llocn rlocn 1323 in 1324 if is_vcons_list rhs then 1325 repeatn (length rhs) pop >> 1326 push ((NonTermVS(List.concat (List.mapPartial get_vsls rhs)), 1327 lrlocn), 1328 XXX) 1329 else 1330 (WARNloc "parse_term" lrlocn "Can't do this sort of reduction"; 1331 error (WARNloc_string lrlocn "Can't do this sort of reduction")) 1332 end 1333 end handle Failloc (loc,s) => 1334 (if !syntax_error_trace then 1335 (print (locn.toString loc); 1336 print ":\n"; 1337 print s; 1338 print "\n") 1339 else (); 1340 error (WARNloc_string loc s)) 1341 1342 val do_reduction = 1343 getstack >- (return o find_reduction) >- perform_reduction 1344 1345 1346 fun el2list x = [x] 1347 (* calls the lexer and puts the result onto the lookahead list *) 1348 val get_item = (lex >- set_la o el2list o liftlocn Token) ++ (set_la []) 1349 1350 (* takes the top (first) terminal from the lookahead list (there is 1351 assumed to be one), and transfers it to the stack. If this 1352 empties the lookahead list, then this is replenished by calling 1353 the appropriate lexer *) 1354 1355 val shift = 1356 current_la >- 1357 (fn la => invstructp >- (return o hd) >- 1358 (fn in_vs => 1359 case la of 1360 [] => error (noloc "No lookahead") 1361 | (x0::xs) => let 1362 val (terminal,locn,x) = transform in_vs (SOME x0) 1363 in 1364 push ((Terminal terminal,locn), valOf x) >> 1365 (if null xs then get_item else set_la xs) >> 1366 (case terminal of 1367 STD_HOL_TOK s => 1368 if is_binder s then enter_binder 1369 else if s = "(" andalso #1 in_vs <> VSRES_Normal then 1370 inc_paren 1371 else if s = ")" andalso #1 in_vs <> VSRES_Normal then 1372 dec_paren 1373 else ok 1374 | ResquanOpTok => enter_restm 1375 | EndBinding => leave_binder 1376 | _ => ok) 1377 end)) 1378 1379 1380 fun doit (tt, (top_item, top_token), in_vs) = let 1381 val (input_term, itlocn, _) = transform (hd in_vs) tt 1382 val top = dest_terminal top_item 1383 val toplocn = #2 top_item 1384 val ttt = Terminal input_term 1385 fun check_for_fnapp_insert stack = 1386 (* if the next thing in the lookahead might begin a whole new phrase, 1387 i.e. is a closed lhs, and the top thing on the stack is a non-terminal 1388 then we should insert the magical function application operator *) 1389 case stack of 1390 ((NonTerminal _,locn), _)::_ => let 1391 val fnt = (LA_Symbol (STD_HOL_TOK fnapp_special),locn.Loc_Near locn) 1392 in 1393 if mem input_term fnapp_closed_lefts then 1394 current_la >- (fn oldla => set_la (fnt::oldla)) 1395 else 1396 qfail 1397 end 1398 | ((NonTermVS _,locn), _) :: _ => let 1399 val fnt = (LA_Symbol VS_cons,locn.Loc_Near locn) 1400 in 1401 if mem input_term fnapp_closed_lefts then 1402 current_la >- (fn oldla => set_la (fnt::oldla)) 1403 else 1404 qfail 1405 end 1406 | _ => qfail 1407 1408 (* a "paren escape" is a CAML style escaping of what would otherwise 1409 be a special token by parenthesising it. Thus (/\) instead of $/\. 1410 The analysis is done at this level rather than inside the lexer to 1411 allow for white-space etc. People will have to write ( * ) to escape 1412 the multiplication symbol, because without the space, it will look like 1413 a comment *) 1414 val check_for_paren_escape = let 1415 fun require (s:string option) = 1416 getstack >- 1417 (fn [] => error (noloc "Stack empty") 1418 | (tt :: _ ) => let 1419 in 1420 case tt of 1421 ((Terminal (STD_HOL_TOK s'),locn), _) => let 1422 in 1423 case s of 1424 NONE => pop >> return (s',locn) 1425 | SOME s'' => 1426 if s' = s'' then pop >> return (s',locn) 1427 else error (WARNloc_string 1428 locn 1429 ("Expected "^s''^", found "^s')) 1430 end 1431 | _ => error (noloc "Expected a terminal") 1432 end) 1433 in 1434 if input_term = STD_HOL_TOK ")" then 1435 require NONE >- 1436 (fn (s,_) => 1437 if s = ")" orelse s = "(" then 1438 qfail (* don't want to paren-escape "())" or "(()" *) 1439 else 1440 require (SOME "(") >- 1441 (fn (_,locn) => let val lrlocn = locn.between locn itlocn 1442 in 1443 shift >> pop >> 1444 (if is_binder s then leave_binder else return ()) >> 1445 invstructp >- (return o #1 o hd) >- 1446 (fn vstate => 1447 if vstate <> VSRES_VS then 1448 push ((NonTerminal (VAR s),lrlocn), XXX) 1449 else 1450 push ((NonTermVS [(SIMPLE s,lrlocn)],lrlocn), XXX)) 1451 end )) 1452 else qfail 1453 end 1454 fun top_might_be_infix stk = 1455 case stk of 1456 ((NonTerminal _, _), _) :: ((Terminal _, _), _) :: 1457 ((NonTerminal _, _), _) :: _ => true 1458 | _ => false 1459 1460 val usual_action = let 1461 fun get_topntp stk = 1462 case stk of 1463 [] => return (false,stk) 1464 | ((Terminal _,_), _) :: _ => return (false,stk) 1465 | _ => return (true,stk) 1466 fun check_order (topntp,stk) = 1467 case Polyhash.peek prec_matrix ((top,topntp), input_term) of 1468 NONE => let 1469 val msg = "Don't expect to find a "^STtoString G input_term^ 1470 " in this position after a "^STtoString G top^"\n"^ 1471 locn.toString itlocn^" and " ^ 1472 locn.toString toplocn^".\n" 1473 in 1474 if !syntax_error_trace then print msg 1475 else (); 1476 error (msg, toplocn) 1477 end 1478 | SOME order => let 1479 fun byorder GREATER = do_reduction 1480 | byorder _ = shift 1481 in 1482 case mx_order order of 1483 SOME x => byorder x 1484 | NONE => let 1485 val (pfx,ifx) = 1486 case order of 1487 PM_LG {pfx,ifx} => (pfx,ifx) 1488 | _ => raise Fail "parse_term: check_order invariant fail" 1489 in 1490 if top_might_be_infix stk then byorder ifx 1491 else byorder pfx 1492 end 1493 end 1494 in 1495 check_for_paren_escape ++ 1496 (getstack >- check_for_fnapp_insert) ++ 1497 (getstack >- get_topntp >- check_order) 1498 end 1499 in 1500 case input_term of 1501 TypeColon => let 1502 (* behaviour has to be slightly tricksy in this case: 1503 - we need to make sure that the next thing that appears in 1504 the stream of tokens is a complete type. 1505 - The way we do this is by calling the type parser on the 1506 remaining input stream and putting the result into the 1507 lookahead list behind the colon. 1508 - We only do this once, so the following action checks to 1509 see that the lookahead list is only one long, otherwise 1510 it can do the normal action 1511 *) 1512 fun action_on_la la = 1513 case la of 1514 [x as (_,locn)] => 1515 lifted_typeparser >- (fn ty => set_la [x, (PreType ty,locn.Loc_Near locn)]) 1516 (* TODO: if lifted_typeparser returned a location, use that *) 1517 | _ => usual_action 1518 in 1519 current_la >- action_on_la 1520 end 1521 | STD_HOL_TOK s => usual_action 1522 | _ => usual_action 1523 end 1524 1525 val current_input = 1526 current_la >- (fn lal => (* lookahead list *) 1527 if null lal then return NONE else return (SOME (hd lal))) 1528 1529 1530 val basic_action = 1531 current_input >- (fn tt (* term token *) => 1532 topterm >- (fn top => 1533 invstructp >- (fn invs => 1534 doit (tt, top, invs)))) 1535 fun notBOS (Terminal BOS) = false 1536 | notBOS _ = true 1537 1538in 1539 push ((Terminal BOS,locn.Loc_None), XXX) >> get_item >> 1540 mwhile (current_input >- 1541 (fn optt => if (isSome optt) then return true 1542 else 1543 topterm >- (fn t => return (notBOS (#1 (#1 t)))))) 1544 basic_action 1545end 1546 1547val initial_pstack = PStack {stack = [], lookahead = [], 1548 in_vstruct = [(VSRES_Normal, 0)]} 1549 1550fun is_final_pstack p = 1551 case p of 1552 PStack {stack = [((NonTerminal pt,_), _), ((Terminal BOS,_), _)], 1553 lookahead = [], in_vstruct = [(VSRES_Normal, 0)]} => true 1554 | _ => false 1555 1556val recupd_errstring = 1557 "Record list must have (fld := value) or (fld updated_by f) elements only" 1558 1559fun to_vabsyn vs = 1560 case vs of 1561 (SIMPLE x,locn) => Absyn.VIDENT (locn,x) 1562 | (VPAIR(v1,v2),locn) => Absyn.VPAIR(locn,to_vabsyn v1, to_vabsyn v2) 1563 | (TYPEDV(v,(ty,_)),locn) => Absyn.VTYPED(locn,to_vabsyn v, ty) 1564 | (VS_AQ x,locn) => Absyn.VAQ (locn,x) 1565 | (RESTYPEDV _,locn) => 1566 raise ParseTermError 1567 ("Attempt to convert a vstruct still containing a RESTYPEDV",locn) 1568 1569fun remove_specials t = 1570 case #1 t of 1571 COMB (t1, t2) => let 1572 open Absyn 1573 in 1574 case #1 t1 of 1575 VAR s => if s = bracket_special then remove_specials t2 1576 else APP(#2 t, IDENT (#2 t1,s), remove_specials t2) 1577 | COMB ((VAR s,slocn), f) => let 1578 in 1579 if s = fnapp_special then APP(#2 t, remove_specials f, remove_specials t2) 1580 else if s = recsel_special then 1581 case #1 t2 of 1582 VAR fldname => APP(#2 t, IDENT (#2 t2, recsel_special ^ fldname), 1583 remove_specials f) 1584 | _ => raise ParseTermError 1585 ("Record selection must have single id to right \ 1586 \(possibly non-integer numeric literal)",#2 t2) 1587 else if s = reccons_special then 1588 remove_recupdate (#2 t) f t2 (QIDENT (locn.Loc_None,"bool", "ARB")) 1589 else if s = recwith_special then 1590 remove_recupdate' (#2 t) t2 (remove_specials f) 1591 else 1592 if s = recupd_special orelse s = recfupd_special then 1593 raise ParseTermError 1594 ("May not use record update functions at top level \ 1595 \(possibly missing semicolon)",slocn) 1596 else 1597 APP(#2 t, remove_specials t1, remove_specials t2) 1598 end 1599 | _ => APP(#2 t, remove_specials t1, remove_specials t2) 1600 end 1601 | ABS(v, t2) => Absyn.LAM(#2 t, to_vabsyn v, remove_specials t2) 1602 | TYPED(t, (ty,_)) => Absyn.TYPED(#2 t, remove_specials t, ty) 1603 | VAR s => Absyn.IDENT(#2 t, s) 1604 | QIDENT(x,y) => Absyn.QIDENT(#2 t, x, y) 1605 | AQ x => Absyn.AQ(#2 t, x) 1606and remove_recupdate locn upd1 updates bottom = let 1607 open Absyn 1608in 1609 case #1 upd1 of 1610 COMB((COMB((VAR s,slocn), (VAR fld,_)),sflocn), newvalue) => let 1611 in 1612 if s = recfupd_special then 1613 APP(locn, APP(#2 upd1, IDENT (sflocn,s^fld), remove_specials newvalue), 1614 remove_recupdate' (#2 updates) updates bottom) 1615 else if s = recupd_special then 1616 APP(locn, APP(#2 upd1, IDENT (sflocn, recfupd_special^fld), 1617 APP(locn.Loc_None, QIDENT(locn.Loc_None, "combin", "K"), 1618 remove_specials newvalue)), 1619 remove_recupdate' (#2 updates) updates bottom) 1620 else raise ParseTermError (recupd_errstring,slocn) 1621 end 1622 | _ => 1623 raise ParseTermError (recupd_errstring,#2 upd1) 1624end 1625and remove_recupdate' locn updatelist bottom = let 1626 open Absyn 1627in 1628 case #1 updatelist of 1629 VAR s => if s = recnil_special then bottom 1630 else raise ParseTermError (recupd_errstring,#2 updatelist) 1631 | COMB((COMB((VAR s,slocn), upd1),sflocn), updates) => let 1632 in 1633 if s = reccons_special then remove_recupdate locn upd1 updates bottom 1634 else 1635 if s = recupd_special orelse s = recfupd_special then 1636 case #1 upd1 of 1637 VAR fldname => 1638 if s = recfupd_special then 1639 APP(locn,APP(#2 upd1, IDENT (sflocn,s^fldname), 1640 remove_specials updates), 1641 bottom) 1642 else 1643 APP(locn,APP(#2 upd1, IDENT (sflocn, recfupd_special^fldname), 1644 APP(locn.Loc_None, 1645 QIDENT(locn.Loc_None, "combin", "K"), 1646 remove_specials updates)), 1647 bottom) 1648 | _ => raise ParseTermError 1649 ("Must have field name as first argument to update operator",#2 upd1) 1650 else 1651 raise ParseTermError (recupd_errstring,slocn) 1652 end 1653 | _ => raise ParseTermError (recupd_errstring,#2 updatelist) 1654end 1655 1656 1657fun top_nonterminal pstack = 1658 case pstack of 1659 PStack {stack = ((NonTerminal pt,locn), _)::_, ...} => remove_specials (pt,locn) 1660 | PStack {stack = ((_,locn),_)::_, ...} => 1661 raise ParseTermError ("No non-terminal on top of stack",locn) 1662 | _ => 1663 raise ParseTermError ("No non-terminal on top of stack",locn.Loc_Unknown(*TODO*)) 1664 1665(* 1666infix Gmerge 1667 1668 1669Useful functions to test with: 1670fun do_parse0 G ty = let 1671 val pt = parse_term G ty 1672in 1673 fn q => let 1674 val ((cs, p), _) = pt (q, PStack {lookahead = [], stack = [], 1675 in_vstruct = false}) 1676 in 1677 case pstack p of 1678 [(NonTerminal pt, _), (Terminal BOS, _)] => remove_specials pt 1679 | _ => raise Fail "Parse failed " 1680 end 1681end 1682 1683Remember to start with 1684 quotation := true 1685in raw MoscowML sessions 1686 1687fun pp (v : ''a) = let 1688 val p:''a frag list -> ''a preterm = 1689 do_parse0 stdhol (parse_type.parse_type parse_type.empty_grammar) 1690in 1691 p 1692end 1693 1694fun ppt (v: ''a) = let 1695 fun fix_stack stack = 1696 case stack of 1697 ((NonTerminal t, _)::rest) => 1698 pop >> push (NonTerminal(remove_specials t), XXX) 1699 | x => ok 1700 val p:''a frag list -> ((''a frag list * ''a PStack) * unit option) = 1701 fn q => 1702 (parse_term stdhol (parse_type.parse_type parse_type.empty_grammar) >> 1703 getstack >- fix_stack) 1704 (q, PStack{lookahead = [], stack = [], in_vstruct = false}) 1705in 1706 p 1707end 1708 1709val p = pp () 1710*) 1711(* 1712quotation := true; 1713val pType = parse_type.pType 1714fun do_test (q, res) = let 1715 val test = p q 1716in 1717 if test <> res then let 1718 in 1719 print "Failure on: \""; 1720 print (quotetoString q); 1721 print "\" not parsing to "; 1722 Meta.printVal res; 1723 print "\n" 1724 end else () 1725end handle _ => print ("Failure of \""^quotetoString q^"\" to parse at all\n"); 1726 1727val tests : (unit frag list * unit preterm) list = 1728[(`x`, VAR "x"), 1729 (`x'`, VAR "x'"), 1730 (`f x`, COMB (VAR "f", VAR "x")), 1731 (`f x y` , COMB (COMB (VAR "f", VAR "x"), VAR "y")), 1732 (`p /\ q`, COMB (COMB (VAR "/\\", VAR "p"), VAR "q")), 1733 (`p /\ q \/ r`, COMB (COMB(VAR "\\/", COMB(COMB(VAR "/\\", VAR "p"), 1734 VAR "q")), 1735 VAR "r")), 1736 (`f : num`, TYPED(VAR "f", parse_type.pType("num", []))), 1737 (`f x : bool list`,TYPED(COMB(VAR "f", VAR "x"), 1738 pType("list", [pType("bool", [])]))), 1739 (`f (p \/ q)`, COMB(VAR "f", COMB (COMB (VAR "\\/", VAR "p"), VAR "q"))), 1740 (`f ^(())`, COMB(VAR "f", AQ ())), 1741 (`f (p:bool \/ q)`,COMB(VAR "f", 1742 COMB(COMB(VAR "\\/", 1743 TYPED(VAR "p", pType("bool", []))), 1744 VAR "q"))), 1745 (`f x.f1`, COMB(VAR "f", COMB(COMB(VAR rec_special, VAR "x"), 1746 VAR "f1"))), 1747 (`f theni`, COMB(VAR "f", VAR "theni")), 1748 (`\x. x`, ABS (SIMPLE "x", VAR "x")), 1749 (`\x y. x`, ABS (SIMPLE "x", ABS (SIMPLE "y", VAR "x"))), 1750 (`?x y. x`, COMB (VAR "?", ABS (SIMPLE "x", 1751 COMB(VAR "?", 1752 ABS(SIMPLE "y", VAR "x"))))), 1753 (`[p; q]`, COMB (COMB(VAR "CONS", VAR "p"), 1754 COMB(COMB(VAR "CONS", VAR "q"), VAR "NIL"))), 1755 (`f [] x`, COMB (COMB (VAR "f", VAR "NIL"), VAR "x")), 1756 (`[[]]`, COMB (COMB (VAR "CONS", VAR "NIL"), VAR "NIL")), 1757 (`\^(()). x`, ABS(VS_AQ(), VAR "x")), 1758 (`f x = if ~f p /\ t then q else r`, 1759 COMB(COMB(VAR "=", COMB(VAR "f", VAR "x")), 1760 COMB(COMB(COMB(VAR "COND", 1761 COMB(COMB(VAR "/\\", 1762 COMB(VAR "~", 1763 COMB(VAR "f",VAR "p"))), 1764 VAR "t")), 1765 VAR "q"), 1766 VAR "r")))]; 1767 1768 1769 1770app do_test tests; 1771 1772*) 1773 1774 1775end 1776