1(*****************************************************************************) 2(* Various ML tools to support ACL2 in HOL including: *) 3(* *) 4(* 1. A printer from HOL to ACL2. *) 5(* *) 6(* 2. A converter from the ML representation of ACL2 defuns, *) 7(* defaxioms and defthms generated by Matt's tool a2ml.csh *) 8(* to HOL term. *) 9(*****************************************************************************) 10 11(*****************************************************************************) 12(* Ignore everything up to "END BOILERPLATE" *) 13(*****************************************************************************) 14 15(*****************************************************************************) 16(* START BOILERPLATE NEEDED FOR COMPILATION *) 17(*****************************************************************************) 18 19(****************************************************************************** 20* Load theories 21******************************************************************************) 22(* The commented out stuff below should be loaded in interactive sessions 23quietdec := true; 24map 25 load 26 ["intSyntax","pairSyntax","listSyntax","stringLib","stringSimps", 27 "rich_listTheory","pred_setLib"]; 28open pairSyntax listSyntax stringLib numLib stringSimps 29 rich_listTheory pred_setLib Defn; 30printDepth := 1000; 31printLength := 1000; 32Globals.checking_const_names := false; 33quietdec := false; 34*) 35 36structure sexp = 37struct 38 39(****************************************************************************** 40* Boilerplate needed for compilation: open HOL4 systems modules 41******************************************************************************) 42open HolKernel Parse boolLib bossLib; 43 44(****************************************************************************** 45* Open theories 46******************************************************************************) 47open intSyntax pairSyntax listSyntax stringLib numLib; 48 49(*****************************************************************************) 50(* END BOILERPLATE *) 51(*****************************************************************************) 52 53(*****************************************************************************) 54(* Print utility from Michael Norrish (may not end up being used): *) 55(* *) 56(* > Is there a way of redirecting output from print_term to a file? *) 57(* *) 58(* You need to turn an outstream (the thing you get back from a call to *) 59(* TextIO.openOut) into a ppstream. You could do this with *) 60(* *) 61(* fun mk_pp_from_out outstream = *) 62(* PP.mk_ppstream { consumer = (fn s => TextIO.output(outstream,s)), *) 63(* linewidth = 80, *) 64(* flush = (fn () => TextIO.flushOut outstream) } *) 65(* *) 66(* where I have chosen the linewidth arbitrarily. Then you would use the *) 67(* ppstream based pretty-printer Parse.pp_term. So a complete solution *) 68(* for outputting a single term to a given file would be *) 69(*****************************************************************************) 70fun mk_pp_from_out outstream = 71 PP.mk_ppstream { consumer = (fn s => TextIO.output(outstream,s)), 72 linewidth = 80, 73 flush = (fn () => TextIO.flushOut outstream) }; 74 75fun print_term_to_file fname term = let 76 val outstr = TextIO.openOut fname 77 val pps = mk_pp_from_out outstr 78in 79 Parse.pp_term pps term; 80 PP.flush_ppstream pps; 81 TextIO.closeOut outstr 82end; 83 84 85(*****************************************************************************) 86(* Swich off warning messages when defining types and constants with *) 87(* non-standard names (e.g. names originating from ACL2). *) 88(*****************************************************************************) 89val _ = (Globals.checking_const_names := false); 90 91(*****************************************************************************) 92(* Flag to determine if HOL_ERR exceptions are printed *) 93(*****************************************************************************) 94val print_err = ref false; 95 96(*****************************************************************************) 97(* Error reporting function (uses some HOL boilerplate I don't understand) *) 98(*****************************************************************************) 99fun err fn_name msg = 100 if !print_err 101 then Raise(mk_HOL_ERR "sexp" fn_name msg) 102 else raise(mk_HOL_ERR "sexp" fn_name msg); 103 104(*****************************************************************************) 105(* Global variable holding current package name. Initially "ACL2". *) 106(*****************************************************************************) 107val current_package = ref "ACL2"; 108 109(*****************************************************************************) 110(* Set value of current package *) 111(*****************************************************************************) 112fun set_current_package pname = 113 (current_package := pname); 114 115(*****************************************************************************) 116(* Global updateable list of ACL2 simplification theorems *) 117(*****************************************************************************) 118val acl2_simps = ref([]:thm list); 119 120(*****************************************************************************) 121(* Function to add a list of theorems to acl2_simps *) 122(*****************************************************************************) 123fun add_acl2_simps thl = (acl2_simps := (!acl2_simps) @ thl); 124 125(*****************************************************************************) 126(* |- ("T" = "NIL") = F -- shouldn't need to have to prove this explicitly! *) 127(*****************************************************************************) 128val T_NIL = EVAL ``"T" = "NIL"``; 129 130val _ = add_acl2_simps[T_NIL]; 131 132(*****************************************************************************) 133(* Tactics that simplifies with acl2_simps and other theorems supplied *) 134(* explicitly by the user *) 135(*****************************************************************************) 136fun ACL2_SIMP_TAC thl = RW_TAC list_ss ((!acl2_simps) @ thl) 137and ACL2_FULL_SIMP_TAC thl = FULL_SIMP_TAC list_ss ((!acl2_simps) @ thl); 138 139(*****************************************************************************) 140(* Global association list of pairs (hol_name, acl2_name). *) 141(*****************************************************************************) 142val acl2_names = 143 ref([("ACL2_PAIR", "COMMON-LISP::CONS")]:(string*string)list); 144 145(*****************************************************************************) 146(* Test if a name is already used *) 147(*****************************************************************************) 148fun is_acl2_name s = can (assoc s) (!acl2_names); 149 150(*****************************************************************************) 151(* Add a pair (hol_name, acl2_name) to acl2_names after checking that *) 152(* hol_name is not already used. *) 153(*****************************************************************************) 154fun add_acl2_name (hol_name, acl2_name) = 155 let val res = assoc1 hol_name (!acl2_names) 156 in 157 case res 158 of SOME(_,acl2_name') 159 => if acl2_name = acl2_name' 160 then () 161 else (print "\""; 162 print hol_name; 163 print "\" is the name of \""; 164 print acl2_name'; 165 print "\n\" so can't use it to name \""; 166 print acl2_name; print "\"\n"; 167 err "add_acl2_name" "name already in use") 168 | NONE 169 => (acl2_names := (hol_name, acl2_name) :: (!acl2_names)) 170 end; 171 172(*****************************************************************************) 173(* Function to add an entry to acl2_names *) 174(*****************************************************************************) 175fun add_acl2_names [] = () 176 | add_acl2_names (p::pl) = (add_acl2_name p; add_acl2_names pl); 177 178(*****************************************************************************) 179(* Print !acl2_names to a string (used in adjoin_to_theory). *) 180(* There may be a better way of doing this! *) 181(*****************************************************************************) 182local 183fun string_pair_list_to_string_aux [] = "" 184 | string_pair_list_to_string_aux [(hol,acl2)] = 185 ("(\"" ^ hol ^ "\",\"" ^ acl2 ^"\")") 186 | string_pair_list_to_string_aux ((hol,acl2)::pl) = 187 ("(\"" ^ hol ^ "\",\"" ^ acl2 ^"\")," ^ 188 string_pair_list_to_string_aux pl) 189in 190fun string_pair_list_to_string pl = 191 ("[" ^ string_pair_list_to_string_aux pl ^ "]") 192end; 193 194(*****************************************************************************) 195(* declare_names("acl2_name","hol_name") *) 196(* *) 197(* 1. Checks "acl2_name" is the name of exactly one constant. *) 198(* *) 199(* 2. Checks "hol_name" isn't an existing abbreviation. *) 200(* *) 201(* 3. Uses the HOL overloading mechanism to introduce "hol_name" *) 202(* as an alternative name for "acl2_name" ("hol_name" should be *) 203(* a valid HOL identifier name). *) 204(*****************************************************************************) 205fun declare_names (acl2_name,hol_name) = 206 let val hol_tml = Term.decls hol_name 207 val acl2_tml = Term.decls acl2_name 208 in 209 if null acl2_tml 210 then (print "no constant named: "; 211 print acl2_name; 212 print "\n"; 213 err "declare_names" "no term with acl2 name") else 214 if not(length acl2_tml = 1) 215 then (print "Warning -- there is more than one constant named: "; 216 print acl2_name; 217 print "\n") else 218 if not(length hol_tml = 0) 219 then (print "Warning -- there is already a constant named: "; 220 print hol_name; 221 print "\n") 222 else (add_acl2_names[(hol_name,acl2_name)]; 223 overload_on(hol_name,hd acl2_tml)) 224 end; 225 226(*****************************************************************************) 227(* ``!x1 ... xn. tm`` |--> tm *) 228(*****************************************************************************) 229val spec_all = snd o strip_forall; 230 231(*****************************************************************************) 232(* Three functions from KXS (modified by MJCG) to support non-standard names *) 233(*****************************************************************************) 234fun dest_hd_eqn eqs = 235 let val hd_eqn = if is_conj eqs then fst(dest_conj eqs) else eqs 236 val (lhs,rhs) = dest_eq (spec_all hd_eqn) 237 in (strip_comb lhs, rhs) 238 end; 239 240fun non_standard_name_defn name q = 241 let val absyn0 = Parse.Absyn q 242 val (qtm,_) = Defn.parse_absyn absyn0 243 val ((f,args),rhs) = dest_hd_eqn qtm 244 val (fname,fty) = dest_var f 245 val qtm' = subst [f |-> mk_var(name,fty)] qtm 246 in 247 (fname, Defn.mk_defn fname qtm') 248 end; 249 250fun non_standard_nameDefine name q = 251 let val (hol_name,def) = non_standard_name_defn name q 252 in 253 ((hol_name, #1(TotalDefn.primDefine def)) 254 handle e => raise wrap_exn "ACL2 support" "xxDefine" e) 255 end; 256 257(*****************************************************************************) 258(* acl2Define "acl2_name" `(foo ... = ...) /\ ... ` does the following: *) 259(* *) 260(* 1. non_standard_nameDefine "acl2_name" `(foo ... = ...) /\ ... ` *) 261(* *) 262(* 2. adds the theorem resulting from the definition to acl2_simps *) 263(* *) 264(* 3. declare_names("acl2_name","hol_name") ("hol_name" is name of hol) *) 265(* *) 266(* 4. the definition theorem is returned *) 267(* *) 268(* Example: *) 269(* *) 270(* val stringp_def = *) 271(* acl2Define "COMMON-LISP::STRINGP" *) 272(* `(stringp(str x) = t) /\ (stringp _ = nil)`; *) 273(* *) 274(*****************************************************************************) 275fun acl2Define acl2_name q = 276 let val (hol_name,th) = non_standard_nameDefine acl2_name q 277 in 278 acl2_simps := (!acl2_simps) @ [th]; 279 declare_names(acl2_name,hol_name); 280 (print"\""; 281 print acl2_name; 282 print "\" defined with HOL name \""; 283 print hol_name; print "\"\n"); 284 th 285 end; 286 287(*****************************************************************************) 288(* acl2_tgoal "acl2_name" `(foo ... = ...) /\ ... ` creates a termination *) 289(* goal for the recursive definition with acl2_name replacing foo. Example: *) 290(* *) 291(* acl2_tgoal "ACL2::TRUE-LISTP" *) 292(* `true_listp x = ite (consp x) (true_listp (cdr x)) (eq x nil)` *) 293(* *) 294(* *) 295(*****************************************************************************) 296fun acl2_tgoal acl2_name q = 297 let val (hol_name,def) = non_standard_name_defn acl2_name q 298 in 299 (print "Creating termination goal for "; 300 print acl2_name; 301 print " ("; print hol_name; print ")\n"; 302 Defn.tgoal def 303 handle e => Raise(wrap_exn "ACL2 support" "Hol_defn" e)) 304 end; 305 306(*****************************************************************************) 307(* acl2_defn "acl2_name" (`(foo ... = ...) /\ ... `, tac) uses tac to *) 308(* solve the termination goal for the recursive definition with acl2_name *) 309(* replacing foo. Makes the definition of acl2_name and then overloads foo *) 310(* on acl2_name. Example: *) 311(* *) 312(* val (true_listp_def,true_listp_ind) = *) 313(* acl2_defn "ACL2::TRUE-LISTP" *) 314(* (`true_listp x = ite (consp x) (true_listp (cdr x)) (eq x nil)`, *) 315(* WF_REL_TAC `measure sexp_size` *) 316(* THEN RW_TAC arith_ss [sexp_size_cdr]); *) 317(*****************************************************************************) 318fun acl2_defn acl2_name (q,tac) = 319 let val (hol_name,def) = non_standard_name_defn acl2_name q 320 val (def_th,ind_th) = 321 (Defn.tprove(def,tac) 322 handle e => Raise(wrap_exn "ACL2 support" "Defn.tgoal" e)) 323 in 324(*acl2_simps := (!acl2_simps) @ [def_th];*) 325 declare_names(acl2_name,hol_name); 326 save_thm((hol_name ^ "_def"),def_th); 327 save_thm((hol_name ^ "_ind"),ind_th); 328 (print"\""; 329 print acl2_name; 330 print "\" defined with HOL name \""; 331 print hol_name; print "\"\n"; 332 (def_th,ind_th)) 333 end; 334 335(*****************************************************************************) 336(* Generate date and time for making file timestamps *) 337(*****************************************************************************) 338fun date() = Date.fmt "%c" (Date.fromTimeLocal (Time.now ())); 339 340(*****************************************************************************) 341(* Create a output stream to a file called file_name.lisp, apply a printer *) 342(* to it and then flush and close the stream. *) 343(*****************************************************************************) 344fun print_lisp_file file_name printer = 345 let val outstr = TextIO.openOut(file_name ^ ".lisp") 346 fun out s = TextIO.output(outstr,s) 347 in 348 (out("; File created from HOL using print_lisp_file on " ^ date() ^ "\n\n"); 349 (* Add time stamp *) 350 (* out("(IN-PACKAGE \"ACL2\")\n\n"); *) 351 (* ACL2 initialisation (currently commented out at Matt's suggestion) *) 352 printer out; 353 TextIO.flushOut outstr; 354 TextIO.closeOut outstr) 355 end; 356 357(*****************************************************************************) 358(* Representation of s-expressions in ML *) 359(* *) 360(* Complex rational a/b + (p/q)i is constructed by mlnum("a","b","p","q"). *) 361(* Must use strings, as ML numerals are 32-bit! *) 362(* *) 363(* con mlchr = fn : char -> mlsexp *) 364(* con mlnum = fn : string * string * string * string -> mlsexp *) 365(* con mlpair = fn : mlsexp * mlsexp -> mlsexp *) 366(* con mlstr = fn : string -> mlsexp *) 367(* con mlsym = fn : string * string -> mlsexp *) 368(* *) 369(* Negative numbers are represented by prefixing the numerator with "-", *) 370(* so denominators b and q should be natural number numerals (0,1,2,...), *) 371(* and numerators a and p should be natural number numerals, possibly with *) 372(* a "-" prefix. Thus mlnum("1","-1","0","1") is invalid. *) 373(*****************************************************************************) 374datatype mlsexp = 375 mlsym of string * string 376 | mlstr of string 377 | mlchr of char 378 | mlnum of string * string * string * string 379 | mlpair of mlsexp * mlsexp; 380 381val mksym = curry mlsym 382and mkstr = mlstr 383and mkchr = mlchr o chr 384and mknum = fn numerator_x => 385 fn denominator_x => 386 fn numerator_y => 387 fn denominator_y => 388 mlnum(numerator_x,denominator_x,numerator_y,denominator_y) 389and mkpair = fn x => 390 fn y => 391 mlpair(x,y); 392 393(*****************************************************************************) 394(* Test and destructor for mlsym *) 395(*****************************************************************************) 396fun is_mlsym (mlsym(_,_)) = true 397 | is_mlsym _ = false; 398 399fun dest_mlsym (mlsym(sym_pac,sym_name)) = (sym_pac,sym_name) 400 | dest_mlsym _ = err "dest_mlsym" "not a sym"; 401 402(*****************************************************************************) 403(* Alternative name for mlstr used to indicate string originates from a *) 404(* list of characters sent from ACL2. *) 405(*****************************************************************************) 406val mk_chars_str = mlstr; 407 408(*****************************************************************************) 409(* Abbreviation for some symbols. *) 410(*****************************************************************************) 411val mlnil = mksym "COMMON-LISP" "NIL" 412val mlt = mksym "COMMON-LISP" "T" 413and mlquote = mksym "COMMON-LISP" "QUOTE" 414and mlcons = mksym "COMMON-LISP" "CONS" 415and mllambda = mksym "COMMON-LISP" "LAMBDA" 416and mldefun = mksym "COMMON-LISP" "DEFUN" 417and mldefun_sk = mksym "ACL2" "DEFUN-SK" 418and ml_forall = mksym "ACL2" "FORALL" 419and ml_exists = mksym "ACL2" "EXISTS" 420and mlinclude = mksym "ACL2" "INCLUDE-BOOK" 421and mlmutual = mksym "ACL2" "MUTUAL-RECURSION" 422and mlencap = mksym "ACL2" "ENCAP" 423and mldefaxiom = mksym "ACL2" "DEFAXIOM" 424and mldefthm = mksym "ACL2" "DEFTHM"; 425 426(*****************************************************************************) 427(* "tag_ty nam" |--> ("tag_ty","nam") *) 428(*****************************************************************************) 429val split_tag = 430 let 431 fun split_tag_chars acc [] = ([],rev acc) 432 | split_tag_chars acc (#" " :: l) = (rev acc,l) 433 | split_tag_chars acc (c :: l) = split_tag_chars (c :: acc) l 434 in 435 (implode ## implode) o split_tag_chars [] o explode 436end; 437 438(*****************************************************************************) 439(* "pkg::nam" |--> ("pkg","nam") *) 440(*****************************************************************************) 441val split_acl2_name = 442 let 443 fun split_acl2_name_chars acc [] = ([],rev acc) 444 | split_acl2_name_chars acc (#":" :: #":" :: l) = (rev acc,l) 445 | split_acl2_name_chars acc (c :: l) = split_acl2_name_chars (c :: acc) l 446 in 447 (implode ## implode) o split_acl2_name_chars [] o explode 448end; 449 450(*****************************************************************************) 451(* Lookup a string in acl2_names. If it corresponds to a full ACL2 name *) 452(* (with package and symbol name separated by "::") then return the ACL2 *) 453(* name. If it corresponds to an ACL2 name without a package name (which *) 454(* shouldn't happen), then add the current_package as package name. If *) 455(* the string isn't in acl2_names and is "ACL2_PAIR" then return *) 456(* mlsym("COMMON-LISP", "CONS"), otherwise split at "::" (or using *) 457(* current_package if no "::") and then use mlsym. *) 458(*****************************************************************************) 459fun string_to_mlsym s = 460 case assoc1 s (!acl2_names) 461 of SOME(_,acl2_name) 462 => let val (pkg,nam) = split_acl2_name acl2_name 463 in 464 mlsym(if pkg = "" then (!current_package) else pkg, nam) 465 end 466 | NONE 467 => if s = "ACL2_PAIR" 468 then mlcons 469 else let val (pkg,nam) = split_acl2_name s 470 in 471 mlsym(if pkg = "" then (!current_package) else pkg, nam) 472 end; 473 474(*****************************************************************************) 475(* Test for a proper list: (x1 . (x2 . ... . (xn . nil) ...)) *) 476(*****************************************************************************) 477fun is_mlsexp_proper_list (sym as mlsym(_,_)) = 478 (sym = mlnil) 479 | is_mlsexp_proper_list (mlpair(_,p)) = 480 is_mlsexp_proper_list p 481 | is_mlsexp_proper_list _ = false; 482 483(*****************************************************************************) 484(* Test for a proper list or an atom *) 485(*****************************************************************************) 486fun is_mlsexp_list (p as mlpair(_,_)) = is_mlsexp_proper_list p 487 | is_mlsexp_list _ = true; 488 489(*****************************************************************************) 490(* Destruct an ML s-expression list: *) 491(* (x1 . (x2 . ... (xn . nil) ...)) |--> [x1,x2,...,xn] *) 492(*****************************************************************************) 493fun dest_mlsexp_list (sym as mlsym(_,_)) = 494 if (sym = mlnil) then [] else [sym] 495 | dest_mlsexp_list (mlpair(p1,p2)) = 496 p1 :: dest_mlsexp_list p2 497 | dest_mlsexp_list p = [p]; 498 499(*****************************************************************************) 500(* [x1,...,xn] --> (mkpair x1 ... (mkpair xn mlnil) ... )) *) 501(*****************************************************************************) 502fun mk_mlsexp_list [] = mlnil 503 | mk_mlsexp_list (x::xl) = mlpair(x, mk_mlsexp_list xl); 504 505(*****************************************************************************) 506(* Test for a quote: (QUOTE x) *) 507(*****************************************************************************) 508fun is_mlquote (mlpair(x,mlpair(_,n))) = (x = mlquote) andalso (n = mlnil) 509 | is_mlquote _ = false; 510 511(*****************************************************************************) 512(* Extract body of a quote: (QUOTE x) |--> x *) 513(*****************************************************************************) 514fun dest_mlquote (mlpair(_,mlpair(x,_))) = x 515 | dest_mlquote _ = err "dest_mlquote" "bad argument"; 516 517(*****************************************************************************) 518(* Make an ML quote x |--> (QUOTE x) *) 519(*****************************************************************************) 520fun mk_mlquote x = mk_mlsexp_list[mlquote,x]; 521 522(*****************************************************************************) 523(* Test for a lambda: ((LAMBDA (x1 ... xm) bdy) (a1 ... an)) *) 524(*****************************************************************************) 525fun is_mllambda (mlpair(mlpair(x,mlpair(params,mlpair(bdy,n))),args)) = 526 (x = mllambda) andalso 527 is_mlsexp_list params andalso 528 is_mlsexp_list args andalso 529 is_mlsexp_list bdy andalso 530 (n = mlnil) 531 | is_mllambda _ = false; 532 533(*****************************************************************************) 534(* Lambda destructor: *) 535(* ((LAMBDA (x1 ... xm) bdy) (a1 ... an)) *) 536(* |--> *) 537(* ([x1, ..., xm], bdy, [a1, ..., an]) *) 538(* *) 539(*****************************************************************************) 540fun dest_mllambda (mlpair(mlpair(_,mlpair(params,mlpair(bdy,_))),args)) = 541 (dest_mlsexp_list params, bdy, dest_mlsexp_list args) 542 | dest_mllambda _ = 543 err "dest_mllambda" "bad argument"; 544 545(*****************************************************************************) 546(* Test for an include-book: (INCLUDE_BOOK book) *) 547(*****************************************************************************) 548fun is_mlinclude 549 (mlpair(x,mlpair(mlstr book,n))) = 550 (x = mlinclude) andalso 551 (n = mlnil) 552 | is_mlinclude _ = false; 553 554(*****************************************************************************) 555(* Include-book destructor: (INCLUDE-BOOK book) |--> book *) 556(*****************************************************************************) 557fun dest_mlinclude b = 558 if is_mlinclude b 559 then case dest_mlsexp_list b 560 of [_,mlstr book] => book 561 | _ => err "dest_mlinclude" "bad case match" 562 else err "dest_mlinclude" "not an include-book"; 563 564(*****************************************************************************) 565(* Include-book Constructor: book |--> (INCLUDE-BOOK book) *) 566(*****************************************************************************) 567fun mk_mlinclude book = 568 mk_mlsexp_list [mlinclude, mlstr book]; 569 570(*****************************************************************************) 571(* Test for a defun: (DEFUN nam (x1 ... xn) bdy) *) 572(*****************************************************************************) 573fun is_mldefun 574 (mlpair(x,mlpair(mlsym(_,_),mlpair(params,mlpair(bdy,n))))) = 575 (x = mldefun) andalso 576 is_mlsexp_list params andalso 577 is_mlsexp_list bdy andalso 578 (n = mlnil) 579 | is_mldefun _ = false; 580 581(*****************************************************************************) 582(* Defun destructor: (DEFUN nam (x1 ... xn) bdy) |-->(nam,[x1,...,xn],bdy) *) 583(*****************************************************************************) 584fun dest_mldefun d = 585 if is_mldefun d 586 then case dest_mlsexp_list d 587 of [_,nam,params,bdy] 588 => (nam, dest_mlsexp_list params, bdy) 589 | _ 590 => err "dest_mldefun" "bad case match" 591 else err "dest_mldefun" "not a defun"; 592 593(*****************************************************************************) 594(* Defun Constructor: (nam,[x1,...,xn],bdy) |--> (DEFUN nam (x1 ... xn) bdy) *) 595(*****************************************************************************) 596fun mk_mldefun (nam, params, bdy) = 597 mk_mlsexp_list [mldefun, nam, mk_mlsexp_list params, bdy]; 598 599(*****************************************************************************) 600(* Test for a defun_sk: (DEFUN-SK nam (x1 ... xn) (QUANT (v1 ... vm) bdy)) *) 601(*****************************************************************************) 602fun is_mldefun_sk 603 (mlpair 604 (x, 605 mlpair 606 (mlsym(_,_), 607 mlpair 608 (params, 609 mlpair 610 (mlpair(quant, mlpair(qvars, mlpair(bdy,n1))), 611 n2))))) = 612 (x = mldefun_sk) andalso 613 is_mlsexp_list params andalso 614 (mem quant [ml_forall,ml_exists]) andalso 615 is_mlsexp_list qvars andalso 616 is_mlsexp_list bdy andalso 617 (n1 = mlnil) andalso 618 (n2 = mlnil) 619 | is_mldefun_sk _ = false; 620 621(*****************************************************************************) 622(* Defun destructor: *) 623(* (DEFUN-SK nam (x1 ... xn) (QUANT (v1 ... vm) bdy)) *) 624(* |--> *) 625(* (nam, [x1,...,xn], quant, qvars, bdy) *) 626(*****************************************************************************) 627fun dest_mldefun_sk d = 628 if is_mldefun_sk d 629 then case dest_mlsexp_list d 630 of [_,nam,params,quant_bdy] 631 => (case dest_mlsexp_list quant_bdy 632 of [quant,qvars,bdy] 633 => (nam, dest_mlsexp_list params, 634 quant, dest_mlsexp_list qvars, bdy) 635 | _ 636 => err "dest_mldefun_sk" "bad quant case match") 637 | _ 638 => err "dest_mldefun_sk" "bad case match" 639 else err "dest_mldefun" "not a defun"; 640 641(*****************************************************************************) 642(* Defun Constructor: *) 643(* (nam,[x1,...,xn],quant,qvars,bdy) *) 644(* |--> *) 645(* (DEFUN-SK nam (x1 ... xn) (quant qvars bdy)) *) 646(*****************************************************************************) 647fun mk_mldefun_sk (nam, params, quant, qvars, bdy) = 648 mk_mlsexp_list 649 [mldefun_sk, nam, mk_mlsexp_list params, 650 mk_mlsexp_list [quant, mk_mlsexp_list qvars, bdy]]; 651 652(*****************************************************************************) 653(* Test for a defaxiom: (DEFAXIOM nam bdy) *) 654(*****************************************************************************) 655fun is_mldefaxiom 656 (mlpair(x,mlpair(mlsym(_,_),mlpair(bdy,n)))) = 657 (x = mldefaxiom) andalso 658 is_mlsexp_list bdy andalso 659 (n = mlnil) 660 | is_mldefaxiom _ = false; 661 662(*****************************************************************************) 663(* Defaxiom destructor: (DEFAXIOM nam bdy) |--> (nam,bdy) *) 664(*****************************************************************************) 665fun dest_mldefaxiom 666 (mlpair(_,mlpair(nam,mlpair(bdy,_)))) = (nam, bdy) 667 | dest_mldefaxiom _ = err "dest_mldefaxiom" "bad argument"; 668 669(*****************************************************************************) 670(* Defaxiom constructor: (nam,bdy) |--> (DEFAXIOM nam bdy) *) 671(*****************************************************************************) 672fun mk_mldefaxiom(nam,bdy) = 673 mk_mlsexp_list [mldefaxiom, nam, bdy]; 674 675(*****************************************************************************) 676(* Test for a defthm: (DEFTHM nam bdy) *) 677(*****************************************************************************) 678fun is_mldefthm 679 (mlpair(x,mlpair(mlsym(_,_),mlpair(bdy,n)))) = 680 (x = mldefthm) andalso 681 is_mlsexp_list bdy andalso 682 (n = mlnil) 683 | is_mldefthm _ = false; 684 685(*****************************************************************************) 686(* Defthm destructor: (DEFTHM nam bdy) |--> (nam,bdy) *) 687(*****************************************************************************) 688fun dest_mldefthm 689 (mlpair(_,mlpair(nam,mlpair(bdy,_)))) = (nam, bdy) 690 | dest_mldefthm _ = err "dest_mldefthm" "bad argument"; 691 692(*****************************************************************************) 693(* Defthm constructor: (nam,bdy) |--> (DEFTHM nam bdy) *) 694(*****************************************************************************) 695fun mk_mldefthm(nam,bdy) = 696 mk_mlsexp_list [mldefthm, nam, bdy]; 697 698(*****************************************************************************) 699(* Test for a mutual: (MUTUAL-RECURSION d1 ... dn) *) 700(*****************************************************************************) 701fun is_mlmutual (mlpair(x, defs)) = 702 (x = mlmutual) andalso is_mlsexp_list defs 703 | is_mlmutual _ = false; 704 705(*****************************************************************************) 706(* Mutual destructor: (MUTUAL-RECURSION d1 ... dn) |--> [d1, ..., dn] *) 707(*****************************************************************************) 708fun dest_mlmutual (mlpair(_, defs)) = dest_mlsexp_list defs 709 | dest_mlmutual _ = err "dest_mlmutual" "bad argument"; 710 711(*****************************************************************************) 712(* Test for a encap: (ENCAP acl2sig events) *) 713(*****************************************************************************) 714fun is_mlencap (mlpair(x, mlpair(acl2sig,events))) = 715 (x = mlencap) andalso is_mlsexp_list acl2sig 716 andalso is_mlsexp_list events 717 | is_mlencap _ = false; 718 719(*****************************************************************************) 720(* Mutual destructor: (ENCAP (s1 ... sm) (e1 ... en)) *) 721(* |--> *) 722(* ([s1, ..., sm],[e1,...,en]) *) 723(*****************************************************************************) 724fun dest_mlencap (mlpair(_, mlpair(acl2sig,events))) = 725 (dest_mlsexp_list acl2sig, dest_mlsexp_list events) 726 | dest_mlencap _ = err "dest_mlencap" "bad argument"; 727 728(*****************************************************************************) 729(* Test for ``nat n`` where n is a numeral *) 730(*****************************************************************************) 731fun is_nat tm = 732 is_comb tm andalso 733 (rator tm = ``nat``) andalso 734 is_numeral(rand tm); 735 736(*****************************************************************************) 737(* Convert ``nat n`` to "n" *) 738(*****************************************************************************) 739fun dest_nat tm = Arbnum.toString(dest_numeral(rand tm)); 740 741(*****************************************************************************) 742(* Test for ``n`` where n is an integer numeral *) 743(*****************************************************************************) 744fun is_integer tm = 745 is_comb tm andalso 746 (if rator tm = ``int_of_num:num->int`` (* $& overloaded on int_of_num *) 747 then is_numeral(rand tm) else 748 if rator tm = ``int_neg:int->int`` (* $~ overloaded on int_neg *) 749 then is_integer(rand tm) else 750 false); 751 752(*****************************************************************************) 753(* Test for ``int n`` where n is an integer numeral *) 754(*****************************************************************************) 755fun is_int tm = 756 is_comb tm andalso 757 (rator tm = ``int``) andalso 758 is_integer(rand tm); 759 760(*****************************************************************************) 761(* Convert an integer term numeral to a string: *) 762(* *) 763(* ``&d1d2...dn`` |--> "d1d2...dn" *) 764(* ``~& d1d2...dn`` |--> "-d1d2...dn" *) 765(*****************************************************************************) 766fun dest_integer tm = 767 let val (opr,args) = strip_comb tm 768 in 769 if opr = ``int_of_num:num->int`` andalso (tl args = []) 770 then (if is_numeral(hd args) 771 then Arbnum.toString(dest_numeral(hd args)) 772 else (print_term tm; 773 print " is not a non-negative integer numeral\n"; 774 err "dest_integer" "not a non-negative integer numeral")) 775 else (if opr = ``int_neg:int->int`` andalso (tl args = []) 776 then ("-" ^ dest_integer(hd args)) 777 else (print_term tm; 778 print " is not an integer numeral\n"; 779 err "dest_integer" "not an integer numeral")) 780 end; 781 782(*****************************************************************************) 783(* Convert ``int n`` to dest_integer ``n`` *) 784(*****************************************************************************) 785fun dest_int tm = dest_integer(rand tm); 786 787(*****************************************************************************) 788(* Replace initial "-" by "~" in a string (converts ACL2 representation of *) 789(* a negative integer to HOL representation). *) 790(*****************************************************************************) 791fun acl2_int_to_hol_int s = 792 let val chars = explode s 793 in 794 if not(null chars) andalso hd chars = #"-" 795 then implode(#"~" :: tl chars) 796 else s 797 end; 798 799(*****************************************************************************) 800(* Test whether a string is a natural number numeral *) 801(*****************************************************************************) 802fun is_num_string s = all Char.isDigit (explode s); 803 804 805(*****************************************************************************) 806(* Test whether a string is an integer numeral *) 807(*****************************************************************************) 808fun is_int_string s = 809 let val sl = explode s 810 in 811 null sl 812 orelse ((hd sl = #"-") andalso all Char.isDigit (tl sl)) 813 orelse all Char.isDigit sl 814 end; 815 816(*****************************************************************************) 817(* Test for ``cpx a b c d`` *) 818(*****************************************************************************) 819fun is_cpx tm = 820 let val (opr,args) = strip_comb tm 821 in 822 (opr = ``cpx``) 823 andalso (length args = 4) 824 andalso is_int_string(dest_integer(el 1 args)) 825 andalso is_num_string(dest_integer(el 2 args)) 826 andalso is_int_string(dest_integer(el 3 args)) 827 andalso is_num_string(dest_integer(el 4 args)) 828 end; 829 830(*****************************************************************************) 831(* ``cpx an ad bn bd`` |--> ("an", "ad", "bn", "bd") *) 832(* *) 833(* Negative numbers are represented with a prefixed "-" (e.g. "-3"). *) 834(*****************************************************************************) 835fun dest_cpx tm = 836 if is_cpx tm (* Probably redundant extra check included for safety *) 837 then 838 let val (_,args) = strip_comb tm 839 in 840 (dest_integer(el 1 args), 841 dest_integer(el 2 args), 842 dest_integer(el 3 args), 843 dest_integer(el 4 args)) 844 end 845 else (print_term tm; 846 print " is not a complex numeral\n"; 847 err "dest_cpx" "not a complex numeral"); 848 849(*****************************************************************************) 850(* mlsym(pkg,nam) |--> "pkg::nam" *) 851(*****************************************************************************) 852fun mlsym_to_string (sym as mlsym(pkg,nam)) = (pkg^"::"^nam) 853 | mlsym_to_string _ = err "mlsym_to_string" "non sym argument"; 854 855(*****************************************************************************) 856(* Association list of pairs of the form ("xyz", c), where c is a *) 857(* constant defined by |- c = "xyz". Used to avoid building terms with *) 858(* lots of string literals. *) 859(*****************************************************************************) 860val string_abbrevs = ref([]: (string * term)list); 861 862(*****************************************************************************) 863(* Check if an abbreviation already exists *) 864(*****************************************************************************) 865fun has_abbrev s = can (assoc s) (!string_abbrevs); 866 867(*****************************************************************************) 868(* Function to add a list of string abbreviations to string_abbrevs *) 869(*****************************************************************************) 870fun add_string_abbrevs tml = (string_abbrevs := (!string_abbrevs) @ tml); 871 872(*****************************************************************************) 873(* Declare constants ACL2_STRING_ABBREV_n, ACL2_STRING_ABBREV_n+1 etc to *) 874(* abbreviate strings in a supplied list. The starting point n is kept in *) 875(* the reference string_abbrev_count. *) 876(* *) 877(* If a string already has an abbreviation or is in a list !no_abbrev_list *) 878(* of strings that shouldn't be abbreviated, then it is ignored. *) 879(*****************************************************************************) 880val string_abbrev_count = ref 0; 881val no_abbrev_list = ref(["NIL","QUOTE"]); 882 883fun make_string_abbrevs [] = () 884 | make_string_abbrevs (s::sl) = 885 if has_abbrev s 886 then (print "Warning: \""; print s; print "\" already abbreviated by "; 887 print_term(assoc s (!string_abbrevs)); print "\n"; 888 make_string_abbrevs sl) else 889 if mem s (!no_abbrev_list) 890 then (print "Warning: \""; print s; print "\" is in !no_abbrev_list\n"; 891 make_string_abbrevs sl) 892 else 893 (add_string_abbrevs 894 [(s, lhs 895 (concl 896 (SPEC_ALL 897 (Define 898 `^(mk_var 899 (("ACL2_STRING_ABBREV_" 900 ^ Int.toString(!string_abbrev_count)), 901 ``:string``)) = 902 ^(fromMLstring s)`))))]; 903 (string_abbrev_count := (!string_abbrev_count)+1); 904 make_string_abbrevs sl); 905 906(*****************************************************************************) 907(* Print !string_abbrevs to a string (used in adjoin_to_theory). *) 908(* There may be a better way of doing this! *) 909(*****************************************************************************) 910local 911fun string_abbrevs_to_string_aux [] = "" 912 | string_abbrevs_to_string_aux [(s,c)] = 913 ("(\"" ^ s ^ "\",Parse.Term`" ^ fst(dest_const c) ^"`)") 914 | string_abbrevs_to_string_aux ((s,c)::pl) = 915 ("(\"" ^ s ^ "\",Parse.Term`" ^ fst(dest_const c) ^"`)," ^ 916 string_abbrevs_to_string_aux pl) 917in 918fun string_abbrevs_to_string pl = 919 ("[" ^ string_abbrevs_to_string_aux pl ^ "]") 920end; 921 922(*****************************************************************************) 923(* Version of fromMLstring that looks up in string_abbrevs. Convert an ML *) 924(* string to a term: return constant from string_abbrevs if one is found, *) 925(* otherwise return a string literal. *) 926(*****************************************************************************) 927fun abbrevMLstring s = 928 assoc s (!string_abbrevs) 929 handle HOL_ERR _ => fromMLstring s; 930 931(*****************************************************************************) 932(* Version of fromHOLstring that looks up in string_abbrevs. *) 933(*****************************************************************************) 934fun abbrevHOLstring c = 935 rev_assoc c (!string_abbrevs) 936 handle HOL_ERR _ => fromHOLstring c; 937 938(*****************************************************************************) 939(* Get the HOL name from ACL2 name. *) 940(* If there is no HOL name (e.g. an ACL2 variable) the ACL2 name is *) 941(* returned. *) 942(*****************************************************************************) 943local 944fun get_hol_name_from_acl2_name_aux [] sym = 945 mlsym_to_string sym 946 | get_hol_name_from_acl2_name_aux ((hol,acl2) :: nl) sym = 947 if acl2 = mlsym_to_string sym 948 then hol 949 else get_hol_name_from_acl2_name_aux nl sym 950in 951fun get_hol_name_from_acl2_name sym = 952 get_hol_name_from_acl2_name_aux (!acl2_names) sym 953end; 954 955(*****************************************************************************) 956(* Test that a type is ``:sexp`` or ``:sexp -> ... -> sexp`` *) 957(*****************************************************************************) 958fun is_sexp_ty ty = 959 let val (tyop,tyargs) = dest_type ty 960 in 961 (tyop = "sexp" 962 orelse (tyop = "fun" 963 andalso hd tyargs = ``:sexp`` 964 andalso is_sexp_ty(hd(tl tyargs)))) 965 end; 966 967(*****************************************************************************) 968(* Translate a term of type ``:sexp`` to an s-expression represented in ML *) 969(*****************************************************************************) 970fun term_to_mlsexp tm = 971 if is_var tm 972 then string_to_mlsym(fst(dest_var tm)) else 973 if is_const tm 974 then 975 (if is_sexp_ty(type_of tm) 976 then string_to_mlsym(fst(dest_const tm)) 977 else (print_term tm; 978 print " has type ``"; 979 print_type(type_of tm); 980 print "`` so is not a first-order function on S-expressions\n"; 981 err "term_to_mlsexp" "constant has bad type")) else 982 if is_string tm 983 then string_to_mlsym(fromHOLstring tm) else 984 if is_nat tm 985 then mlnum(dest_nat tm, "1", "0", "1") else 986 if is_int tm 987 then mlnum(dest_int tm, "1", "0", "1") else 988 if is_cpx tm 989 then mlnum(dest_cpx tm) else 990 if is_numeral tm 991 then (print "Bad occurence of numeral "; 992 print_term tm; print ". Use \"nat\", \"int\" or \"cpx\".\n"; 993 err "term_to_mlsexp" "bad occurrence of a numeral") else 994 if is_integer tm 995 then (print "Bad occurence of integer numeral "; 996 print_term tm; print ". Use \"nat\", \"int\" or \"cpx\".\n"; 997 err "term_to_mlsexp" "bad occurrence of an integer numeral") else 998 if is_let tm 999 then 1000 let val (param_arg_tuples,bdy) = dest_anylet tm 1001 val (param_tuples,arg_tuples) = unzip param_arg_tuples 1002 val args = (flatten o map strip_pair) arg_tuples 1003 val params = (flatten o map strip_pair) param_tuples 1004 in 1005 if not(length params = length args) 1006 then (print_term tm; print "\n"; 1007 print "different numbers of formal and actual parameters\n"; 1008 err "term_to_mlsexp" "formal/actual mismatch") 1009 else mk_mlsexp_list 1010 (mk_mlsexp_list 1011 [mllambda, 1012 mk_mlsexp_list(map term_to_mlsexp params), 1013 term_to_mlsexp bdy] 1014 :: map term_to_mlsexp args) 1015 end else 1016 if is_comb tm 1017 then 1018 let val (opr,args) = strip_comb tm 1019 in 1020 if is_const opr 1021 then (case fst(dest_const opr) 1022 of "ACL2_SYMBOL" => mk_mlquote 1023 (mlsym(abbrevHOLstring(hd args), 1024 abbrevHOLstring(hd(tl args)))) 1025 | "ACL2_STRING" => mlstr(abbrevHOLstring(hd args)) 1026 | "ACL2_CHARACTER" => mlchr(fromHOLchar(hd args)) 1027 | "ACL2_NUMBER" => (print_term tm; print "\n"; 1028 print "term built with num not supported"; 1029 print " -- use nat, int or cpx\n"; 1030 err "term_to_mlsexp" 1031 "ACL2_NUMBER case unsupported") 1032 | "cpx" => (print_term tm; print "\n"; 1033 print "bad use of cpx\n"; 1034 err "term_to_mlsexp" 1035 "badly formed application of cpx") 1036 | _ => mk_mlsexp_list 1037 (map term_to_mlsexp (opr::args)) 1038 1039 ) else 1040 if is_var opr 1041 then mk_mlsexp_list (map term_to_mlsexp (opr::args)) else 1042 if is_abs opr 1043 then 1044 let val (params,bdy) = strip_abs opr 1045 in 1046 if not(length params = length args) 1047 then (print_term tm; print "\n"; 1048 print "different numbers of formal and actual parameters\n"; 1049 err "term_to_mlsexp" "formal/actual mismatch") 1050 else mk_mlsexp_list 1051 (mk_mlsexp_list 1052 [mllambda, 1053 mk_mlsexp_list(map term_to_mlsexp params), 1054 term_to_mlsexp bdy] 1055 :: map term_to_mlsexp args) 1056 end else 1057 (print_term opr; 1058 print " is not allowed as a function\n"; 1059 err "term_to_mlsexp" "bad function") 1060 end else 1061 (print_term tm; print "\n"; 1062 print "bad argument to term_to_mlsexp\n"; 1063 err "term_to_mlsexp" "bad argument"); 1064 1065(*****************************************************************************) 1066(* Print an ML s-expression s on an output stream out *) 1067(*****************************************************************************) 1068fun print_mlsexp (out:string->unit) (sym as mlsym(_,_)) = 1069 out(mlsym_to_string sym) 1070 | print_mlsexp (out:string->unit) (mlstr s) = 1071 (out "\""; out s; out "\"") 1072 | print_mlsexp (out:string->unit) (mlchr c) = 1073 (out "(code-char "; out(int_to_string(ord c)); out ")") 1074 | print_mlsexp (out:string->unit) (mlnum(an,ad,bn,bd)) = 1075 if (bn = "0") andalso (bd = "1") 1076 then (out an; out "/"; out ad) 1077 else (out "(COMMON-LISP::COMPLEX "; 1078 out an; out "/"; out ad; 1079 out " "; 1080 out bn; out "/"; out bd; 1081 out ")") 1082 | print_mlsexp (out:string->unit) (mlpair(p1,p2)) = 1083 (out "("; 1084 (if is_mlsexp_list p2 1085 then let val sl = dest_mlsexp_list p2 1086 in 1087 if null sl 1088 then print_mlsexp out p1 1089 else (print_mlsexp out p1; 1090 map (fn p => (out " "; print_mlsexp out p)) sl; 1091 ()) 1092 end 1093 else (print_mlsexp out p1; out " . "; print_mlsexp out p2)); 1094 out ")"); 1095 1096(*****************************************************************************) 1097(* Print an ML s-expression to the interactive session *) 1098(*****************************************************************************) 1099fun pr_mlsexp s = (print_mlsexp print s; print "\n"); 1100 1101(*****************************************************************************) 1102(* Print an s-expression term to the interactive session *) 1103(*****************************************************************************) 1104fun pr_sexp t = pr_mlsexp(term_to_mlsexp t); 1105 1106(*****************************************************************************) 1107(* Extract the name of a constant or variable *) 1108(*****************************************************************************) 1109exception get_name_fail; 1110fun get_name tm = 1111 if is_const tm 1112 then fst(dest_const tm) else 1113 if is_var tm then fst(dest_var tm) 1114 else raise get_name_fail; 1115 1116(*****************************************************************************) 1117(* ``f x1 ... xn = e`` --> (defun f (x1 ... xn) ^(term_to_mlsexp e)) *) 1118(*****************************************************************************) 1119fun deftm_to_mlsexp_defun tm = 1120 let val (l,r) = dest_eq(spec_all tm) 1121 val (opr, args) = strip_comb l 1122 in 1123 mk_mlsexp_list 1124 [mksym "COMMON-LISP" "DEFUN", 1125 string_to_mlsym(get_name opr), 1126 mk_mlsexp_list(map term_to_mlsexp args), 1127 term_to_mlsexp r] 1128 end; 1129 1130(*****************************************************************************) 1131(* Translate a hol-acl2 definition *) 1132(* *) 1133(* |- f x1 ... xn = e *) 1134(* *) 1135(* to an ML s-expression representing *) 1136(* *) 1137(* (defun f (x1 ... xn) ^(term_to_mlsexp e)) *) 1138(*****************************************************************************) 1139fun def_to_mlsexp_defun th = 1140 let val (asl, concl) = dest_thm(SPEC_ALL th) 1141 val _ = if not(asl = []) 1142 then(print_thm th; 1143 print "\n"; print"should not have any assumptions\n"; 1144 err "mk_mlsexp_defthm" "assumptions not allowed") 1145 else () 1146 in 1147 deftm_to_mlsexp_defun concl 1148 end; 1149 1150(*****************************************************************************) 1151(* Print a hol-acl2 definition *) 1152(* *) 1153(* |- f x1 ... xn = e *) 1154(* *) 1155(* as *) 1156(* *) 1157(* (defun f (x1 ... xn) ^(term_to_mlsexp e)) *) 1158(*****************************************************************************) 1159fun pr_mlsexp_defun th = pr_mlsexp(def_to_mlsexp_defun th); 1160 1161(*****************************************************************************) 1162(* Code for processing ACL2 defuns slurped into HOL via Matt's a2ml tool *) 1163(*****************************************************************************) 1164 1165(*****************************************************************************) 1166(* Convert a string to integer numeral *) 1167(* *) 1168(* string_to_int_term "37" = ``37`` *) 1169(* string_to_int_term "~37" = ``~37`` *) 1170(* string_to_int_term "-37" = ``~37`` *) 1171(*****************************************************************************) 1172fun string_to_int_term s = intSyntax.term_of_int(Arbint.fromString s); 1173 1174(*****************************************************************************) 1175(* There are two obvious ways to convert an mlsexp to a term: *) 1176(* *) 1177(* 1. recursively descend through it build up a term; *) 1178(* *) 1179(* 2. convert it to a string s than then use Term[QUOTE s]. *) 1180(* *) 1181(* Method 1 allows more detailed checking and gives finer control over *) 1182(* error messages. Method 2 is a bit easier to implement, but may be *) 1183(* less robust. *) 1184(* *) 1185(* Initially we started to implement Method 2 as it was simpler, but then *) 1186(* it became clear that it would not handle ACL2's non standard *) 1187(* identifier names, so we switched to Method 1. *) 1188(* *) 1189(* However, the unfinished partial implementation of Method 2 *) 1190(* (mlsexp_to_string) is useful for debugging, as it enables one to print *) 1191(* compact representations of imported mlsexps. *) 1192(* *) 1193(*****************************************************************************) 1194 1195(*****************************************************************************) 1196(* Convert an ML s-expression (mlsexp) to a string that will parse to the *) 1197(* corresponding HOL s-expression (sexp). *) 1198(*****************************************************************************) 1199fun mlquote_to_string (mlsym(pkg,nam)) = 1200 ("(sym \"" ^ pkg ^ "\" \"" ^ nam ^"\")") 1201 | mlquote_to_string (mlstr s) = 1202 ("(str " ^ "\"" ^ s ^ "\")") 1203 | mlquote_to_string (mlchr c) = 1204 ("(chr " ^ "(CHR " ^ int_to_string(ord c) ^ "))") 1205 | mlquote_to_string (mlnum(an,ad,bn,bd)) = 1206 ("(cpx " ^ 1207 acl2_int_to_hol_int an ^ " " ^ 1208 acl2_int_to_hol_int ad ^ " " ^ 1209 acl2_int_to_hol_int bn ^ " " ^ 1210 acl2_int_to_hol_int bd ^")") 1211 | mlquote_to_string (mlpair(x,y)) = 1212 ("(cons " ^ mlquote_to_string x ^ " " ^ mlquote_to_string y ^ ")"); 1213 1214(*****************************************************************************) 1215(* Convert an ML s-expression (mlsexp) to a string that will parse to the *) 1216(* corresponding HOL s-expression (sexp). *) 1217(*****************************************************************************) 1218fun mlquote_to_string (mlsym(pkg,nam)) = 1219 ("(sym \"" ^ pkg ^ "\" \"" ^ nam ^"\")") 1220 | mlquote_to_string (mlstr s) = 1221 ("(str " ^ "\"" ^ s ^ "\")") 1222 | mlquote_to_string (mlchr c) = 1223 ("(chr " ^ "(CHR " ^ int_to_string(ord c) ^ "))") 1224 | mlquote_to_string (mlnum(an,ad,bn,bd)) = 1225 ("(cpx " ^ 1226 acl2_int_to_hol_int an ^ " " ^ 1227 acl2_int_to_hol_int ad ^ " " ^ 1228 acl2_int_to_hol_int bn ^ " " ^ 1229 acl2_int_to_hol_int bd ^")") 1230 | mlquote_to_string (mlpair(x,y)) = 1231 ("(cons " ^ mlquote_to_string x ^ " " ^ mlquote_to_string y ^ ")"); 1232 1233(*****************************************************************************) 1234(* Convert an ML s-expression (mlsexp) to the coresponding HOL *) 1235(* s-expression (i.e. term of type sexp). *) 1236(*****************************************************************************) 1237fun mlquote_to_term (sym as mlsym(pkg,nam)) = 1238 if sym = mlnil then ``nil`` else 1239 if sym = mlt then ``t`` else 1240 ``sym ^(abbrevMLstring pkg) ^(abbrevMLstring nam)`` 1241 | mlquote_to_term (mlstr s) = 1242 ``str ^(abbrevMLstring s)`` 1243 | mlquote_to_term (mlchr c) = 1244 ``chr ^(fromMLchar c)`` 1245 | mlquote_to_term (mlnum(an,ad,bn,bd)) = 1246 ``cpx ^(string_to_int_term an) 1247 ^(string_to_int_term ad) 1248 ^(string_to_int_term bn) 1249 ^(string_to_int_term bd)`` 1250 | mlquote_to_term (mlpair(x,y)) = 1251 ``cons ^(mlquote_to_term x) ^(mlquote_to_term y)``; 1252 1253(*****************************************************************************) 1254(* Convert an mlsexp representing a term to a string. *) 1255(* *) 1256(* From: http://www.dina.kvl.dk/~sestoft/mosmllib/List.html *) 1257(* *) 1258(* [foldl op% e xs] evaluates xn % (x(n-1) % ( ... % (x2 % (x1 % e)))) *) 1259(* where xs = [x1, x2, ..., x(n-1), xn], and % is taken to be infixed. *) 1260(* *) 1261(*****************************************************************************) 1262fun mlsexp_to_string (sym as mlsym(_,_)) = 1263 mlsym_to_string sym 1264 | mlsexp_to_string (mlstr s) = ("(str " ^ "\"" ^ s ^ "\")") 1265 | mlsexp_to_string (mlchr c) = 1266 ("(chr " ^ "(CHR " ^ int_to_string(ord c) ^ "))") 1267 | mlsexp_to_string (mlnum(an,ad,bn,bd)) = 1268 ("(cpx " ^ 1269 acl2_int_to_hol_int an ^ " " ^ 1270 acl2_int_to_hol_int ad ^ " " ^ 1271 acl2_int_to_hol_int bn ^ " " ^ 1272 acl2_int_to_hol_int bd ^")") 1273 | mlsexp_to_string (p as mlpair(x,y)) = 1274 if is_mlquote p 1275 then mlquote_to_string(dest_mlquote p) 1276 else ("(" ^ 1277 (if is_mlsexp_list y 1278 then foldl 1279 (fn (z,zs) => zs ^ " " ^ mlsexp_to_string z) 1280 (mlsexp_to_string x) 1281 (dest_mlsexp_list y) 1282 else (print "attempt to translate a non-list to a term\n"; 1283 err "mlsexp_to_string" "non-list")) ^ 1284 ")"); 1285 1286(*****************************************************************************) 1287(* mlsym(pkg,nam) |--> mk_var("pkg::nam",``:sexp``) *) 1288(*****************************************************************************) 1289fun param_to_var (sym as mlsym(_,_)) = 1290 mk_var(mlsym_to_string sym,``:sexp``) 1291 | param_to_var _ = 1292 (print "Not a mlsym\n"; 1293 err "param_to_var" "parameter not an mlsym"); 1294 1295(*****************************************************************************) 1296(* mlsym(pkg,nam) ty |--> mk_var("pkg::nam",ty) *) 1297(*****************************************************************************) 1298fun name_to_var (sym as mlsym(_,_)) ty = 1299 mk_var(mlsym_to_string sym,ty) 1300 | name_to_var _ _ = 1301 (print "Not a mlsym\n"; 1302 err "name_to_var" "name not an mlsym"); 1303 1304(*****************************************************************************) 1305(* Look up the HOL name of an ACL2 name and return the corresponding *) 1306(* term. Return a variable with a supplied type if there is no HOL name. *) 1307(*****************************************************************************) 1308val acl2_name_to_term_print_flag = ref false; 1309 1310local 1311fun if_print s = if (!acl2_name_to_term_print_flag) then print s else () 1312in 1313fun acl2_name_to_term sym ty = 1314 if sym = mlt 1315 then ``t`` else 1316 if sym = mlnil 1317 then ``nil`` else 1318 if sym = mlcons 1319 then ``ACL2_PAIR`` else 1320 let val sym_string = mlsym_to_string sym 1321 val sym_terms = Term.decls sym_string 1322 val sym_types = map (snd o dest_const) sym_terms 1323 in 1324 if mem ty sym_types 1325 then mk_const(sym_string,ty) 1326 else (if_print "Warning: \""; 1327 if_print sym_string; 1328 if_print "\" made a variable by acl2_name_to_term\n"; 1329 mk_var(sym_string,ty)) 1330 end 1331end; 1332 1333(*****************************************************************************) 1334(* n |--> ``:sexp -> ... -> sexp`` (n arguments) *) 1335(*****************************************************************************) 1336fun mk_sexp_fun_ty n = 1337 if n = 0 then ``:sexp`` else ``:sexp -> ^(mk_sexp_fun_ty(n-1))``; 1338 1339(*****************************************************************************) 1340(* list_mk_abs doesn't create an abstraction when the arg list is empty *) 1341(*****************************************************************************) 1342val list_mk_fun = list_mk_abs; 1343 1344(*****************************************************************************) 1345(* Convert an mlsexp representing a term to the term. *) 1346(*****************************************************************************) 1347fun mlsexp_to_term (sym as mlsym(_,_)) = 1348 acl2_name_to_term sym ``:sexp`` 1349 | mlsexp_to_term (mlstr s) = ``str ^(abbrevMLstring s)`` 1350 | mlsexp_to_term (mlchr c) = ``chr ^(fromMLchar c)`` 1351 | mlsexp_to_term (mlnum(an,ad,bn,bd)) = 1352 ``cpx ^(string_to_int_term an) 1353 ^(string_to_int_term ad) 1354 ^(string_to_int_term bn) 1355 ^(string_to_int_term bd)`` 1356 | mlsexp_to_term (p as mlpair(x,y)) = 1357 if is_mlquote p 1358 then mlquote_to_term(dest_mlquote p) else 1359 if is_mllambda p 1360 then let val (params,bdy,args) = dest_mllambda p 1361 in 1362 list_mk_comb 1363 (list_mk_fun(map param_to_var params, mlsexp_to_term bdy), 1364 map mlsexp_to_term args) 1365 end else 1366 if is_mlsexp_list y 1367 then let val args = map mlsexp_to_term (dest_mlsexp_list y) 1368 val opr = if is_mlsym x 1369 then acl2_name_to_term 1370 x 1371 (mk_sexp_fun_ty(length args)) 1372 else mlsexp_to_term x 1373 in 1374 (list_mk_comb(opr,args) 1375 handle HOL_ERR _ => 1376 (print "Can't make term\n"; 1377 print(mlsexp_to_string p); 1378 print "\n"; 1379 err "mlsexp_to_term" "bad mlsexp")) 1380 end else 1381 (print "attempt to translate a non-list to a term\n"; 1382 err "mlsexp_to_term" "non-list"); 1383 1384(*****************************************************************************) 1385(* (defun d (x1 ... xm) b) |--> "d x1 ... xm = b" *) 1386(*****************************************************************************) 1387fun defun_to_string d = 1388 if is_mldefun d 1389 then let val (sym, params, bdy) = dest_mldefun d 1390 in 1391 foldl 1392 (fn (z,zs) => zs ^ " " ^ z) 1393 ("ACL2_" ^ mlsym_to_string sym) 1394 (map mlsym_to_string params) 1395 ^ " = " ^ mlsexp_to_string bdy 1396 end 1397 else (print "defun badly formed\n"; 1398 err "defun_to_string" "bad defun"); 1399 1400(*****************************************************************************) 1401(* Test for a defun, defaxiom or defthm *) 1402(*****************************************************************************) 1403fun is_mldef d = 1404 is_mldefun d orelse is_mldefun_sk d orelse is_mldefaxiom d orelse is_mldefthm d; 1405 1406(*****************************************************************************) 1407(* ``f = \x1 ... xn. bdy`` --> ``f x1 ... xn = bdy`` *) 1408(*****************************************************************************) 1409fun mk_def_eq tm = 1410 if is_eq tm 1411 then foldl 1412 (fn (v,t) => mk_eq(mk_comb(lhs t,v),beta_conv(mk_comb(rhs t,v)))) 1413 tm 1414 (fst(strip_abs(rhs tm))) 1415 else tm; 1416 1417(*****************************************************************************) 1418(* |- f = \x1 ... xn. bdy *) 1419(* ---------------------- *) 1420(* |- f x1 ... xn = bdy *) 1421(*****************************************************************************) 1422fun MK_DEF_EQ th = 1423 if is_eq(concl(SPEC_ALL th)) 1424 then foldl 1425 (fn (v,th) => RIGHT_CONV_RULE BETA_CONV (AP_THM th v)) 1426 th 1427 (fst(strip_abs(rhs(concl(SPEC_ALL th))))) 1428 else th; 1429 1430(*****************************************************************************) 1431(* Conversion *) 1432(* *) 1433(* ``(\x1 ... xn. t) y1 .. yn`` *) 1434(* --> *) 1435(* |- (\x1 ... xn. t) y1 .. yn = let (x1,...,xn) = (y1,...,yn) in t *) 1436(* *) 1437(*****************************************************************************) 1438fun LET_INTRO_CONV tm = 1439 let val (opr, args) = strip_comb tm 1440 val (params,bdy) = strip_abs opr 1441 val param_arg_list = filter 1442 (fn (v1,v2) => not(aconv v1 v2)) 1443 (zip params args) 1444 val let_tm = ``LET 1445 ^(mk_pabs(list_mk_pair params,bdy)) 1446 ^(list_mk_pair args)`` 1447 val th1 = DEPTH_CONV (REWR_CONV LET_THM) let_tm 1448 val th2 = DEPTH_CONV BETA_CONV tm 1449 val th3 = DEPTH_CONV PairRules.PBETA_CONV(rhs(concl th1)) 1450 in 1451 GSYM(TRANS(TRANS th1 th3)(GSYM th2)) 1452 end; 1453 1454(*****************************************************************************) 1455(* Flag to determine whether to introduce lets *) 1456(*****************************************************************************) 1457val let_flag = ref true; 1458 1459(*****************************************************************************) 1460(* Rule to introduce let throughout a term *) 1461(*****************************************************************************) 1462fun LET_INTRO th = 1463 if !let_flag 1464 then CONV_RULE (TRY_CONV(RHS_CONV(TOP_DEPTH_CONV LET_INTRO_CONV))) th 1465 else th; 1466 1467(****************************************************************************** 1468The method of converting a full ACL2 name pkg::sym to a HOL-friendly 1469name is as follows (see definition of create_hol_name below). 1470 1471 1. First see if the ACL2 name already has a HOL name, and if so 1472 return it. 1473 1474 2. Convert sym to a HOL name, say hol_sym, using the ML function 1475 acl2_name_to_hol_name (this function is described below). 1476 1477 3. If hol_sym starts with a digit, then use acl2_name_to_hol_name 1478 to convert pkg to hol_pkg, then lengthen the name to 1479 (hol_pkg ^ "_" ^ hol_sym). 1480 1481 4. Check to see if sym_name (or the lengthened name) is already used. 1482 If not it is the result. 1483 1484 5. If hol_sym is in use and doesn't start with a digit, then see if 1485 (hol_pkg ^ "_" ^ hol_sym) is used, and if not return it. If it is 1486 in use an error report is printed and an exception raised. 1487 1488 6. Record any names generated by steps above in acl2_names so 1489 the original names can be recovered. 1490 1491The function acl2_name_to_hol_name converts a string s to a 1492HOL-friendly name as follows. 1493 1494 1. Convert s to a list of characters and convert all letters 1495 to lower-case. 1496 1497 2. Replace "-" by "_". 1498 1499 3. Replace special characters by strings of letter characters 1500 using acl2_to_hol_char_map (defined below). Add an underscore 1501 "_" to separate special characters from all other characters. 1502 1503We think these simple rules should be sufficient in practice, and if 1504they are not it's better to reconsider carefully what to do rather 1505than to have ugly looking names generated by more complicated rules 1506(this might change if the sufficiency assumption is badly wrong). 1507******************************************************************************) 1508 1509 1510(*****************************************************************************) 1511(* Map from ACL2 characters in names to lists of HOL-friendly characters. *) 1512(*****************************************************************************) 1513val acl2_to_hol_char_map = 1514 [(#"=" , explode "equal"), 1515 (#"<" , explode "less"), 1516 (#">" , explode "greater"), 1517 (#"/" , explode "slash"), 1518 (#"\\" , explode "backslash"), 1519 (#"?" , explode "question"), 1520 (#"$" , explode "dollar"), 1521 (#"!" , explode "exclaim"), 1522 (#"*" , explode "star"), 1523 (#"+" , explode "plus"), 1524 (#":" , explode "colon"), 1525 (#" " , explode "space")]; 1526 1527(*****************************************************************************) 1528(* Check is a character is in the domain of acl2_to_hol_char_map. *) 1529(*****************************************************************************) 1530fun isSpecial c = can (assoc c) acl2_to_hol_char_map; 1531 1532(*****************************************************************************) 1533(* Convert a character to a list of HOL-friendly characters by applying *) 1534(* acl2_to_hol_char_map. If the character is not in the domain of *) 1535(* acl2_to_hol_char_map, then if it is #"-" it is converted to #"_" else *) 1536(* it is converted to lower case. *) 1537(*****************************************************************************) 1538fun acl2_char_to_hol_chars c = 1539 if Char.isAlphaNum c 1540 then [Char.toLower c] else 1541 if c = #"-" then [#"_"] 1542 else assoc c acl2_to_hol_char_map handle HOL_ERR _ => [c]; 1543 1544fun acl2_chars_to_hol_chars [] = [] 1545 | acl2_chars_to_hol_chars [c] = acl2_char_to_hol_chars c 1546 | acl2_chars_to_hol_chars (c1::(cl as (c2::_))) = 1547 if (isSpecial c1 orelse isSpecial c2) 1548 andalso not(c1 = #"-") andalso not(c2 = #"-") 1549 then acl2_char_to_hol_chars c1@(#"_"::acl2_chars_to_hol_chars cl) 1550 else acl2_char_to_hol_chars c1@acl2_chars_to_hol_chars cl; 1551 1552(*****************************************************************************) 1553(* ACL2 to HOL name conversion function. Treats first character specially. *) 1554(*****************************************************************************) 1555fun acl2_name_to_hol_name acl2_name = 1556 case assoc2 acl2_name (!acl2_names) 1557 of SOME (hol_name,_) => hol_name 1558 | NONE => implode(acl2_chars_to_hol_chars(explode acl2_name)); 1559 1560(*****************************************************************************) 1561(* Create a HOL-friendly name from a full ACL2 name and remember it in *) 1562(* acl2_names. No effect on names unchanged by acl2_name_to_hol_name. *) 1563(* *) 1564(* The package name is eliminated unless it's needed to disambiguate HOL *) 1565(* names (e.g. if the symbol symbol name occurs with two package names). *) 1566(*****************************************************************************) 1567fun create_hol_name acl2_name = 1568 if acl2_name = acl2_name_to_hol_name acl2_name 1569 then acl2_name 1570 else 1571 let val (pkg_name,sym_name) = split_acl2_name acl2_name 1572 val hol_pkg_name = acl2_name_to_hol_name pkg_name 1573 val hol_sym_name = acl2_name_to_hol_name sym_name 1574 val long_hol_name = (hol_pkg_name ^ "_" ^ hol_sym_name) 1575 val fst_char = hd(explode hol_sym_name) 1576 in 1577 if Char.isDigit fst_char 1578 then 1579 (case (assoc1 long_hol_name (!acl2_names)) 1580 of SOME(_,acl2_name') 1581 => if acl2_name = acl2_name' 1582 then long_hol_name 1583 else (print "\""; 1584 print long_hol_name; 1585 print "\" is the name of \""; 1586 print acl2_name'; 1587 print "\"\nso can't use it to name \""; 1588 print acl2_name; print "\"\n"; 1589 err "create_hol_name" "name already in use (case 1)") 1590 | NONE 1591 => (acl2_names := (long_hol_name, acl2_name)::(!acl2_names); 1592 long_hol_name) 1593 ) 1594 else 1595 (case (assoc1 hol_sym_name (!acl2_names)) 1596 of SOME(_,acl2_name') 1597 => if acl2_name = acl2_name' 1598 then hol_sym_name 1599 else 1600 (case (assoc1 long_hol_name (!acl2_names)) 1601 of SOME(_,acl2_name'') 1602 => if acl2_name = acl2_name'' 1603 then long_hol_name 1604 else (print "\""; 1605 print hol_sym_name; 1606 print "\" is the name of \""; 1607 print acl2_name'; 1608 print "\"\nso can't use it to name \""; 1609 print acl2_name; print "\"\n"; 1610 print "\""; 1611 print long_hol_name; 1612 print "\" is the name of \""; 1613 print acl2_name''; 1614 print "\"\nso can't use it to name \""; 1615 print acl2_name; print "\"\n"; 1616 err "create_hol_name" "name already in use (case 2)") 1617 | NONE 1618 => (acl2_names := (long_hol_name, acl2_name)::(!acl2_names); 1619 long_hol_name) 1620 ) 1621 | NONE 1622 => (acl2_names := (hol_sym_name, acl2_name)::(!acl2_names); 1623 hol_sym_name) 1624 ) 1625 end; 1626 1627(*****************************************************************************) 1628(* ML datatype to represent HOL tems and other data (e.g. names) of *) 1629(* events imported from ACL2 *) 1630(* *) 1631(* A defun contains a defining equation: ``!x1 ... xn. f x1 ... xn = e`` *) 1632(* (the universal quantification may be partial or absent) *) 1633(* *) 1634(* A defaxiom or defthm consists of a name and a term. *) 1635(* *) 1636(* A mutual represents MUTUAL-RECURSION and is a defining term (normally a *) 1637(* conjunction of universally quantified equations) suitable for processing *) 1638(* by Define. *) 1639(* *) 1640(* An encap represents ENCAPSULATE and is a pair comprising the list of *) 1641(* names of the events specifying the functions being introduced and the *) 1642(* defining term (normally an existential quantification) suitable for *) 1643(* processing by new_specification. *) 1644(*****************************************************************************) 1645datatype acl2def = 1646 defun of term 1647 | defaxiom of string * term 1648 | defthm of string * term 1649 | mutual of term 1650 | encap of (string list) * term; 1651 1652(*****************************************************************************) 1653(* Strip ``|=`` from defthms and defaxioms *) 1654(*****************************************************************************) 1655fun dest_ax_or_thm conc = 1656 let val (con,tm) = dest_comb conc 1657 val _ = if not(is_const con andalso (fst(dest_const con) = "|=")) 1658 then(print_term conc; 1659 print " should have form |= ...\n"; 1660 err "dest_ax_or_thm" "missing |=") 1661 else () 1662 in 1663 tm 1664 end; 1665 1666(*****************************************************************************) 1667(* "s1 s2 ... sn" |--> ["s1","s2",...,"sn"] (split at spaces) *) 1668(*****************************************************************************) 1669val split_at_spaces = String.tokens (fn c => c = #" "); 1670 1671(*****************************************************************************) 1672(* Convert a theorem obtained by slurping in ACL2 to an acl2def option. *) 1673(* Used for reproving ACL2 imports inside HOL and for round-trip printing. *) 1674(*****************************************************************************) 1675local 1676exception fail_for_mapfilter 1677in 1678fun dest_acl2_thm th = 1679 let val (asl, conc) = dest_thm(SPEC_ALL th) 1680 val _ = if not(asl = []) 1681 then(print_thm th; 1682 print "\n"; print"should not have any assumptions\n"; 1683 err "dest_acl2_thm" "assumptions not allowed") 1684 else () 1685 val tg = tag th 1686 val (tgl1,tgl2) = Tag.dest_tag tg 1687 val stgl = mapfilter 1688 (fn s => 1689 let val (s1,s2) = split_tag s 1690 in 1691 if mem s1 ["DEFUN","DEFAXIOM","DEFTHM", 1692 "MUTUAL-RECURSION","ENCAPSULATE"] 1693 then (s1,s2) 1694 else raise fail_for_mapfilter 1695 end) 1696 tgl1 1697 in 1698 if length stgl > 1 1699 then (print_thm th; 1700 print " has more than one ACL2 def tags!\n"; 1701 err "dest_acl2_thm" "more than one ACL2 tag") else 1702 if null stgl 1703 then NONE 1704 else case (fst(hd stgl)) 1705 of "DEFUN" 1706 => SOME(defun conc) 1707 | "DEFAXIOM" 1708 => SOME(defaxiom(snd(hd stgl), dest_ax_or_thm conc)) 1709 | "DEFTHM" 1710 => SOME(defthm(snd(hd stgl), dest_ax_or_thm conc)) 1711 | "MUTUAL-RECURSION" 1712 => SOME(mutual conc) 1713 | "ENCAPSULATE" 1714 => SOME(encap(split_at_spaces(snd(hd stgl)), conc)) 1715 | _ => NONE 1716 end 1717end; 1718 1719(*****************************************************************************) 1720(* Convert a hol theorem to a defthm *) 1721(*****************************************************************************) 1722fun thm_to_defthm(name,th) = 1723 defthm (name, dest_ax_or_thm(concl(SPEC_ALL th))); 1724 1725(*****************************************************************************) 1726(* Extraxt content from an option *) 1727(*****************************************************************************) 1728fun dest_option (SOME x) = x 1729 | dest_option NONE = err "dest_option" "NONE"; 1730 1731(*****************************************************************************) 1732(* ``PKG::SYM`` |--> create_hol_name "PKG::SYM" *) 1733(*****************************************************************************) 1734fun clean_acl2_var tm = 1735 if is_var tm 1736 then let val (s,ty) = dest_var tm 1737 val hol_name = create_hol_name s 1738 in 1739 mk_var(hol_name, ty) 1740 end 1741 else tm; 1742 1743(*****************************************************************************) 1744(* Clean all the free variables in a term *) 1745(*****************************************************************************) 1746fun clean_acl2_term tm = 1747 subst (map (fn v => v |-> clean_acl2_var v) (free_vars tm)) tm; 1748 1749(*****************************************************************************) 1750(* Clean all the free variables in a theorem *) 1751(*****************************************************************************) 1752fun CLEAN_ACL2_FREES th = 1753 INST (map (fn v => v |-> clean_acl2_var v) (thm_frees th)) th; 1754 1755(*****************************************************************************) 1756(* Conversion to clean a bound variable of an abstraction *) 1757(*****************************************************************************) 1758fun CLEAN_ACL2_ALPHA_CONV tm = 1759 let val (v,bdy) = dest_abs tm 1760 val (vname,vty) = dest_var v 1761 val hol_vname = create_hol_name vname 1762 in 1763 if hol_vname = vname 1764 then ALL_CONV tm 1765 else ALPHA_CONV (mk_var(hol_vname, vty)) tm 1766 end; 1767 1768(*****************************************************************************) 1769(* Conversion to clean all bound variables in a term *) 1770(*****************************************************************************) 1771val CLEAN_ACL2_BOUND_CONV = DEPTH_CONV CLEAN_ACL2_ALPHA_CONV; 1772 1773(*****************************************************************************) 1774(* Rule to clean all variables in a theorem *) 1775(*****************************************************************************) 1776val CLEAN_ACL2_VARS = 1777 LET_INTRO o CLEAN_ACL2_FREES o CONV_RULE CLEAN_ACL2_BOUND_CONV; 1778 1779(*****************************************************************************) 1780(* deftm(defun tm) = tm *) 1781(* deftm(defthm(_, tm)) = tm *) 1782(* deftm(defaxiom(_, tm)) = tm *) 1783(*****************************************************************************) 1784fun deftm(defun tm) = tm 1785 | deftm(defthm(_, tm)) = tm 1786 | deftm(defaxiom(_, tm)) = tm 1787 | deftm _ = err "deftm" "bad arg"; 1788 1789(*****************************************************************************) 1790(* ``!v1...vn. f v1 ... vn = tm`` |--> f *) 1791(*****************************************************************************) 1792fun get_defined tm = fst(strip_comb(lhs(spec_all tm))); 1793 1794(*****************************************************************************) 1795(* defun ``!v1...vn. f v1 ... vn = tm`` |--> f *) 1796(* fails on non-defuns *) 1797(*****************************************************************************) 1798exception get_defun_fun_fail; 1799fun get_defun_fun (defun tm) = get_defined tm 1800 | get_defun_fun _ = raise get_defun_fun_fail; 1801 1802(*****************************************************************************) 1803(* defname(defun ``!x1 ... xn. f x1 ... xn = t,``) = f *) 1804(* defname(defthm(nam, _)) = nam *) 1805(* defname(defaxiom(nam, _)) = nam *) 1806(*****************************************************************************) 1807fun defname(defun tm) = get_name(get_defined tm) 1808 | defname(defthm(nam,_)) = nam 1809 | defname(defaxiom(nam,_)) = nam 1810 | defname _ = err "defname" "bad arg"; 1811 1812(*****************************************************************************) 1813(* mk_sexp_fun_ty n |--> ``:sexp -> ... -> sexp -> sexp`` (n arguments) *) 1814(*****************************************************************************) 1815fun mk_sexp_fun_ty n = 1816 if n = 0 then ``:sexp`` else ``:sexp -> ^(mk_sexp_fun_ty(n-1))``; 1817 1818(*****************************************************************************) 1819(* mk_closed_event vl tm |--> ``!v1 ... vn. tm`` *) 1820(* *) 1821(* where v1,...,vn are the free variables in tm not in vl *) 1822(*****************************************************************************) 1823fun mk_closed_event vl tm = list_mk_forall(subtract(free_vars tm)vl, tm); 1824 1825(*****************************************************************************) 1826(* mk_acl2def converts an ML representation of an ACL2 event into an *) 1827(* equivalent hol acl2def specification *) 1828(* *) 1829(* (defun nam (x1 ... xm) bdy) *) 1830(* |--> *) 1831(* defun("nam", ``!x1 ... xm. nam x1 ..., xm = bdy``) *) 1832(* *) 1833(* (defthm nam bdy) *) 1834(* |--> *) 1835(* defthm("nam", ``|= tm``) *) 1836(* *) 1837(* (defaxiom nam bdy) *) 1838(* |--> *) 1839(* defaxiom("nam", ``|= tm``) *) 1840(* *) 1841(* (mutual-recursion d1 ... dn) *) 1842(* |--> *) 1843(* mutual ``^(deftm(mk_acl2def d1)) /\ ... /\ ^(deftm(mk_acl2def dn))`` *) 1844(* *) 1845(* (encapsulate ((v1 ... ) ... (vm ... )) e1 ... en) *) 1846(* |--> *) 1847(* encap *) 1848(* ([``n1``,...,``nm``], *) 1849(* ``?v1 ... vm. *) 1850(* ^(deftm(mk_acl2def e1)) /\ ... /\ ^(deftm(mk_acl2def en))``) *) 1851(* *) 1852(* where n1,...,nm are the names of the events introducing v1,...,vm, *) 1853(* respectively *) 1854(*****************************************************************************) 1855fun mk_acl2def d = 1856 if is_mldefun d 1857 then 1858 let val (nam,params,bdy) = dest_mldefun d 1859 val param_vars = map param_to_var params 1860 val bdy_tm = mlsexp_to_term bdy 1861 val tm = list_mk_fun(param_vars, bdy_tm) 1862 val ty = type_of tm 1863 val unbound_vars = 1864 subtract (free_vars bdy_tm) (name_to_var nam ty :: param_vars) 1865 val _ = if null unbound_vars 1866 then () 1867 else print("Warning: " 1868 ^ snd(dest_mlsym nam) 1869 ^ " has unbound free variables\n") 1870 1871 val sym_name = mlsym_to_string nam 1872 val newvar = mk_var(sym_name,ty) 1873 val defun_tm = list_mk_forall(param_vars, mk_def_eq(mk_eq(newvar,tm))) 1874 in 1875 defun(mk_closed_event [newvar] defun_tm) 1876 end else 1877 if is_mldefun_sk d 1878 then 1879 let val (nam,params,quant,qvars,bdy) = dest_mldefun_sk d 1880 val param_vars = map param_to_var params 1881 val quant_vars = map param_to_var qvars 1882 val quant_bdy = ``|= ^(mlsexp_to_term bdy)`` 1883 val quant_tm = 1884 if quant = ml_forall 1885 then list_mk_forall(quant_vars, quant_bdy) else 1886 if quant = ml_exists 1887 then list_mk_exists(quant_vars, quant_bdy) 1888 else err "mk_acl2def" (snd(dest_mlsym quant) ^ ": bad quantifier") 1889 val tm = list_mk_fun(param_vars, ``bool_to_sexp ^quant_tm``) 1890 val ty = type_of tm 1891 val unbound_vars = 1892 subtract (free_vars quant_tm) (name_to_var nam ty :: param_vars) 1893 val _ = if null unbound_vars 1894 then () 1895 else print("Warning: " 1896 ^ snd(dest_mlsym nam) 1897 ^ " has unbound free variables\n") 1898 val sym_name = mlsym_to_string nam 1899 val newvar = mk_var(sym_name,ty) 1900 val defun_tm = list_mk_forall(param_vars, mk_def_eq(mk_eq(newvar,tm))) 1901 in 1902 defun(mk_closed_event [newvar] defun_tm) 1903 end else 1904 if is_mldefthm d 1905 then 1906 let val (nam,bdy) = dest_mldefthm d 1907 val tm = mlsexp_to_term bdy 1908 val ty = type_of tm 1909 val sym_name = mlsym_to_string nam 1910 in 1911 defthm(sym_name, gen_all ``|= ^tm``) 1912 end else 1913 if is_mldefaxiom d 1914 then 1915 let val (nam,bdy) = dest_mldefaxiom d 1916 val tm = mlsexp_to_term bdy 1917 val ty = type_of tm 1918 val sym_name = mlsym_to_string nam 1919 in 1920 defaxiom(sym_name, gen_all ``|= ^tm``) 1921 end else 1922 if is_mlmutual d 1923 then 1924 let val dl = dest_mlmutual d 1925 val names = map (mlsym_to_string o #1 o dest_mldefun) dl 1926 in 1927 mutual(gen_all(list_mk_conj(map (deftm o mk_acl2def) dl))) 1928 end else 1929 if is_mlencap d 1930 then 1931 let val (sigl,dl) = dest_mlencap d 1932 val sigll = map dest_mlsexp_list sigl 1933 val sig_vars = 1934 map 1935 (fn l => 1936 mk_var 1937 (mlsym_to_string(hd l), 1938 mk_sexp_fun_ty(length(dest_mlsexp_list(hd(tl l)))))) 1939 sigll 1940 val eventl = map mk_acl2def dl 1941 val defunl = mapfilter get_defun_fun eventl 1942 val extended_sig_vars = union sig_vars defunl 1943 val names = map defname eventl 1944 val event_tms = 1945 map (mk_closed_event extended_sig_vars o spec_all o deftm) eventl 1946 val spec_body = list_mk_exists(extended_sig_vars,list_mk_conj event_tms) 1947 in 1948 encap(names,gen_all spec_body) 1949 end 1950 else err "mk_acl2def" "badly formed mldef"; 1951 1952(*****************************************************************************) 1953(* Convert a list of character code to a string. *) 1954(* Used in ML generated from ACL2 by a2ml. *) 1955(*****************************************************************************) 1956val chars_to_string = implode o (map chr); 1957 1958(*****************************************************************************) 1959(* ["s1","s2",...,"sn"] |--> "s1 s2 ... sn" (strings separated by spaces) *) 1960(*****************************************************************************) 1961fun concat_with_spaces [] = "" 1962 | concat_with_spaces [s] = s 1963 | concat_with_spaces (s::sl) = s ^ " " ^ concat_with_spaces sl; 1964 1965(*****************************************************************************) 1966(* Get list of things being defined by a mutual recursion *) 1967(*****************************************************************************) 1968val get_defined_list = map get_defined o strip_conj o spec_all; 1969 1970(*****************************************************************************) 1971(* Space-separated concatenation of names of defuns in a mutual-recursion *) 1972(*****************************************************************************) 1973val mk_mutual_name = concat_with_spaces o map get_name o get_defined_list; 1974 1975(*****************************************************************************) 1976(* Print an acl2def *) 1977(*****************************************************************************) 1978fun print_acl2def out (defun tm) = 1979 (out "; Defun: "; out(get_name(get_defined tm)); out "\n"; 1980 print_mlsexp out (deftm_to_mlsexp_defun(spec_all tm)); 1981 out "\n\n") 1982 | print_acl2def out (defaxiom(nam,tm)) = 1983 (out "; Defaxiom: "; out nam; out "\n"; 1984 print_mlsexp out 1985 (mk_mlsexp_list 1986 [mldefaxiom, 1987 string_to_mlsym nam, 1988 term_to_mlsexp(spec_all tm)]); 1989 out "\n\n") 1990 | print_acl2def out (defthm(nam,tm)) = 1991 (out "; Defthm: "; out nam; out "\n"; 1992 print_mlsexp out 1993 (mk_mlsexp_list 1994 [mldefthm, 1995 string_to_mlsym nam, 1996 term_to_mlsexp(spec_all tm)]); 1997 out "\n\n") 1998 | print_acl2def out (mutual tm) = 1999 (out "; Mutual-Recursion "; out (mk_mutual_name tm); out "\n"; 2000 out "(MUTUAL-RECURSION\n\n"; 2001 map (print_acl2def out o defun) (strip_conj tm); 2002 out ")\n\n") 2003 | print_acl2def out (encap(sl,tm)) = err "print_acl2def" "encap not yet supported"; 2004(* 2005 (out "; Encapsulate\n"; 2006 map (print_acl2def out o defthm) (strip_conj(snd(strip_exists tm))); 2007 out "\n"); 2008*) 2009 2010(*****************************************************************************) 2011(* Convert a preterm to a string (used for inputting ACL2) *) 2012(*****************************************************************************) 2013local 2014fun drop_until_close [] = [] (* drop chars until comment closes *) 2015 | drop_until_close (#"*" :: #")" :: l) = l 2016 | drop_until_close (c :: l) = drop_until_close l 2017fun strip_comments [] = [] (* remove comments *) 2018 | strip_comments (#"(" :: #"*" :: l) = strip_comments(drop_until_close l) 2019 | strip_comments (c :: l) = c :: strip_comments l 2020fun strip_loc s = implode(strip_comments(explode s)) 2021fun unQUOTE(QUOTE s) = s (* QUOTE s |--> s *) 2022 | unQUOTE _ = err "unQUOTE" "not applied to a QUOTE" 2023in 2024val preterm_to_string = 2025 foldr (fn(q,sl) => strip_loc(unQUOTE (q:term frag)) ^ "\n" ^ sl) "" 2026end; 2027 2028(*****************************************************************************) 2029(* Absolute path of acl2 directory *) 2030(*****************************************************************************) 2031val acl2_path = ref(Globals.HOLDIR ^ "/examples/acl2"); 2032 2033(*****************************************************************************) 2034(* Location of a2ml.csh tool for converting ACL2 files to ML files *) 2035(*****************************************************************************) 2036val a2ml = ((!acl2_path) ^ "/lisp/a2ml.csh"); 2037 2038(*****************************************************************************) 2039(* Location of pprint-file.csh. tool for pretty-printing ACL2 files *) 2040(*****************************************************************************) 2041val pp = ((!acl2_path) ^ "/lisp/pprint-file.csh"); 2042 2043(*****************************************************************************) 2044(* Reference into which mlsexp generated by a2ml is put *) 2045(*****************************************************************************) 2046val acl2_list_ref = ref([] : mlsexp list); 2047 2048(*****************************************************************************) 2049(* Wrapper around mk_oracle_thm. *) 2050(* Saves strings used to create tags (now strings) in acl2_tags. *) 2051(*****************************************************************************) 2052val acl2_tags = ref([]: (string*(string*string))list); 2053 2054fun mk_acl2_thm defty acl2_name deftm = 2055 let val tg = defty ^ " " ^ acl2_name 2056 in 2057 (acl2_tags := (tg,(defty,acl2_name)) :: (!acl2_tags); 2058 mk_oracle_thm tg ([], deftm)) 2059 end; 2060 2061(*****************************************************************************) 2062(* Sequentially process, install and save the contents of acl2_list_ref: *) 2063(* *) 2064(* 1. declare constants in defuns, then make definition using mk_oracle_thm; *) 2065(* *) 2066(* 2. declare HOL-friendly names (declare_names) using names generated *) 2067(* with create_hol_name. *) 2068(* *) 2069(* 3. create theorems using mk_oracle_thm then save them with a HOL-friendly *) 2070(* name with suffix "_defun", "_axiom", "_thm", "_mutual" or "_encap" *) 2071(*****************************************************************************) 2072fun install(defun tm) = 2073 let val opr = get_defined tm 2074 val (opr_name,opr_ty) = dest_var opr 2075 val _ = if not(null(Term.decls opr_name)) 2076 then (print "\""; 2077 print opr_name; 2078 print "\" can only be defined once\n"; 2079 err "install" "repeated defun event") 2080 else () 2081 val (pkg_name,sym_name) = split_acl2_name opr_name 2082 val hol_name = create_hol_name opr_name 2083 val new_hol_name = 2084 (if null(Term.decls hol_name) then "" else "acl2_") ^ hol_name 2085 val _ = new_constant(opr_name,opr_ty) 2086 val _ = declare_names(opr_name,new_hol_name) 2087 val con = mk_const(opr_name,opr_ty) 2088 val newtm = subst[opr |-> con]tm 2089 val save_name = hol_name ^ "_defun" 2090 val defun_thm = 2091 save_thm 2092 (save_name, CLEAN_ACL2_VARS(mk_acl2_thm "DEFUN" opr_name newtm)) 2093 in 2094 (save_name,defun_thm) 2095 end 2096 | install(defaxiom(acl2_name, tm)) = 2097 let val (pkg_name,sym_name) = split_acl2_name acl2_name 2098 val hol_name = create_hol_name acl2_name 2099 val save_name = hol_name ^ "_axiom" 2100 val defaxiom_thm = 2101 save_thm 2102 (save_name, CLEAN_ACL2_VARS(mk_acl2_thm "DEFAXIOM" acl2_name tm)) 2103 in 2104 (save_name,defaxiom_thm) 2105 end 2106 | install(defthm(acl2_name, tm)) = 2107 let val (pkg_name,sym_name) = split_acl2_name acl2_name 2108 val hol_name = create_hol_name acl2_name 2109 val save_name = hol_name ^ "_thm" 2110 val defthm_thm = 2111 save_thm 2112 (save_name, 2113 CLEAN_ACL2_VARS(mk_acl2_thm "DEFTHM" acl2_name tm)) 2114 in 2115 (save_name,defthm_thm) 2116 end 2117 | install(mutual tm) = 2118 let val tms = get_defined_list tm 2119 val opr_name_ty_list = map dest_var tms 2120 val acl2_name = mk_mutual_name tm 2121 val hol_names = map (create_hol_name o fst) opr_name_ty_list 2122 val new_hol_names = 2123 map 2124 (fn tm => (if null(Term.decls tm) then "" else "acl2_") ^ tm) 2125 hol_names 2126 val _ = map new_constant opr_name_ty_list 2127 val _ = map2 2128 (fn (nam,ty) => fn new_nam => declare_names(nam,new_nam)) 2129 opr_name_ty_list 2130 new_hol_names 2131 val con_list = map mk_const opr_name_ty_list 2132 val newtm = 2133 subst 2134 (map2 (fn opr => fn con => (opr |-> con)) tms con_list) 2135 (spec_all tm) 2136 val hol_name = create_hol_name acl2_name 2137 val save_name = hol_name ^ "_mutual" 2138 val defthm_thm = 2139 save_thm 2140 (save_name, 2141 CLEAN_ACL2_VARS (mk_acl2_thm "MUTUAL-RECURSION" acl2_name newtm)) 2142 in 2143 (save_name,defthm_thm) 2144 end 2145 | install(encap(sl,bdy)) = 2146 let val (tms,tm) = strip_exists bdy 2147 val opr_name_ty_list = map dest_var tms 2148 val acl2_name = concat_with_spaces(map get_name tms) 2149 val hol_names = map (create_hol_name o fst) opr_name_ty_list 2150 val new_hol_names = 2151 map 2152 (fn tm => (if null(Term.decls tm) then "" else "acl2_") ^ tm) 2153 hol_names 2154 val _ = map new_constant opr_name_ty_list 2155 val _ = map2 2156 (fn (nam,ty) => fn new_nam => declare_names(nam,new_nam)) 2157 opr_name_ty_list 2158 new_hol_names 2159 val con_list = map mk_const opr_name_ty_list 2160 val newtm = 2161 subst 2162 (map2 (fn opr => fn con => (opr |-> con)) tms con_list) 2163 tm 2164 val hol_name = create_hol_name acl2_name 2165 val save_name = hol_name ^ "_encap" 2166 val defthm_thm = 2167 save_thm 2168 (save_name, 2169 CLEAN_ACL2_VARS(mk_acl2_thm "ENCAPSULATE" acl2_name newtm)) 2170 in 2171 (save_name,defthm_thm) 2172 end; 2173 2174(*****************************************************************************) 2175(* Get kind of acl2def *) 2176(*****************************************************************************) 2177fun dest_acl2def (defun tm) = ("DEFUN",get_name(get_defined tm)) 2178 | dest_acl2def (defaxiom(s,_)) = ("DEFAXIOM",s) 2179 | dest_acl2def (defthm(s,_)) = ("DEFTHM",s) 2180 | dest_acl2def (mutual tm) = ("MUTUAL-RECURSION", mk_mutual_name tm) 2181 | dest_acl2def (encap(sg,tm)) = ("ENCAPSULATE", concat_with_spaces sg); 2182 2183(*****************************************************************************) 2184(* install plus a printing wrapper. *) 2185(*****************************************************************************) 2186fun install_and_print a = 2187 let val (kind,name) = dest_acl2def a 2188 val _ = (print kind; print " "; print name; print "\n") 2189 val th = snd(install a) 2190 val _ = print_thm th 2191 val _ = print "\n\n" 2192 in 2193 th 2194 end; 2195 2196(*****************************************************************************) 2197(* Union a list of lists *) 2198(*****************************************************************************) 2199fun union_flatten [] = [] 2200 | union_flatten (l::ll) = union l (union_flatten ll);; 2201 2202(*****************************************************************************) 2203(* Gets the symbol names from an ML S-expression *) 2204(*****************************************************************************) 2205fun get_package_strings(mlsym(_,s)) = [s] 2206 | get_package_strings(mlpair(p1,p2)) = 2207 union (get_package_strings p1) (get_package_strings p2) 2208 | get_package_strings _ = []; 2209 2210(*****************************************************************************) 2211(* Match a defun -- identity function if match succeeds *) 2212(*****************************************************************************) 2213fun match_defun full_acl2_name mlsexp = 2214 case mlsexp 2215 of (mlpair(mlsym("COMMON-LISP", "DEFUN"), 2216 mlpair(mlsym(pkg, sym), _))) 2217 => if (pkg, sym) = split_acl2_name full_acl2_name 2218 then mlsexp 2219 else raise err "match_defun" 2220 ("bad match: (\"" ^ pkg ^ "\",\"" ^ sym ^ "\")") 2221 | _ => raise err "match_defun" 2222 ("bad case match: " ^ full_acl2_name); 2223 2224(*****************************************************************************) 2225(* Match a defaxiom -- identity function if match succeeds *) 2226(*****************************************************************************) 2227fun match_defaxiom full_acl2_name mlsexp = 2228 case mlsexp 2229 of (mlpair(mlsym("ACL2", "DEFAXIOM"), 2230 mlpair(mlsym(pkg, sym), _))) 2231 => if (pkg, sym) = split_acl2_name full_acl2_name 2232 then mlsexp 2233 else raise err "match_defaxiom" 2234 ("bad match: (\"" ^ pkg ^ "\",\"" ^ sym ^ "\")") 2235 | _ => raise err "match_defaxiom" 2236 ("bad case match: " ^ full_acl2_name); 2237 2238(*****************************************************************************) 2239(* Match a defthm -- identity function if match succeeds *) 2240(*****************************************************************************) 2241fun match_defthm full_acl2_name mlsexp = 2242 case mlsexp 2243 of (mlpair(mlsym("ACL2", "DEFTHM"), 2244 mlpair(mlsym(pkg, sym), _))) 2245 => if (pkg, sym) = split_acl2_name full_acl2_name 2246 then mlsexp 2247 else raise err "match_defthm" 2248 ("bad match: (\"" ^ pkg ^ "\",\"" ^ sym ^ "\")") 2249 | _ => raise err "match_defthm" 2250 ("bad case match: " ^ full_acl2_name); 2251 2252(*****************************************************************************) 2253(* Run a command returning true if it was successful. *) 2254(* This is a nasty hack to ensure this file works in both MoscowML *) 2255(* and PolyML. My apologies. *) 2256(*****************************************************************************) 2257 2258fun run_with_test string = 2259 (Process.system (string ^ "&& touch success") ; 2260 can FileSys.remove "success"); 2261 2262(*****************************************************************************) 2263(* Print a list of ACL2 DEFUNs to a file defun-tmp.lisp, *) 2264(* then run a2ml to create defun-tmp.ml. *) 2265(*****************************************************************************) 2266 2267fun print_defuns_to_mlsexps ql = 2268 let val sl = map preterm_to_string ql 2269 val _ = print_lisp_file "defun-tmp" (fn pr => map pr sl) 2270in 2271 if not (run_with_test 2272 (a2ml ^ " defun-tmp.lisp defun-tmp.ml >& defun-tmp.log")) 2273 then (print "a2ml defun-tmp.lisp defun-tmp.ml: Failed\n"; 2274 print "\n"; 2275 err "print_defuns_to_mlsexs" "a2ml failed") else 2276 () 2277 end; 2278 2279(*****************************************************************************) 2280(* Create a script file for a theory named thy that contains ACL2 DEFUNs ql *) 2281(* and hol names specified in an alist name_alist *) 2282(*****************************************************************************) 2283fun print_acl2_defun_script thy ql name_alist= 2284 let val outstr = TextIO.openOut("header-tmp.ml") 2285 fun out s = TextIO.output(outstr,s) 2286 in 2287 out("(* File created from HOL using print_acl2_defun_script on " 2288 ^ date() ^ " *)\n\n"); 2289 out "open HolKernel Parse boolLib bossLib;\n"; 2290 out "open stringLib complex_rationalTheory gcdTheory sexp sexpTheory;\n"; 2291 out ("val _ = new_theory \"" ^ thy ^ "\";"); 2292 out "\n\n"; 2293 out "val name_alist = \n"; 2294 out(string_pair_list_to_string name_alist); 2295 out ";\n\n"; 2296 TextIO.flushOut outstr; 2297 TextIO.closeOut outstr; 2298 print_defuns_to_mlsexps ql; 2299 Process.system 2300 ("cat header-tmp.ml defun-tmp.ml end-boilerplate.ml > " 2301 ^ thy ^ "Script.sml") 2302 end; 2303 2304(*****************************************************************************) 2305(* Read contents of acl2_list_ref (which should be set by slurping in *) 2306(* ACL2 stuff), convert to tagged theorems and put the results in *) 2307(* imported_acl2_theorems (an assignable variable). *) 2308(* *) 2309(* The protocol for using this is: *) 2310(* *) 2311(* use (Globals.HOLDIR ^ "/examples/acl2/..."); *) 2312(* load_imported_acl2_theorems(); *) 2313(*****************************************************************************) 2314val imported_acl2_theorems = ref([]:thm list); 2315 2316fun load_imported_acl2_theorems () = 2317 let val acl2_package_strings = 2318 union_flatten 2319 (mapfilter 2320 (get_package_strings o match_defaxiom "ACL2::ACL2-PACKAGE") 2321 (!acl2_list_ref)) 2322 val string_abbrev_count = length(!string_abbrevs) 2323 in 2324 print "Making string abbreviations ...\n"; 2325 make_string_abbrevs acl2_package_strings; 2326 print(Int.toString(length(!string_abbrevs)-string_abbrev_count)); 2327 print " new string abbreviations made\n"; 2328 show_tags := true; 2329 print "read "; print(Int.toString(length(!acl2_list_ref))); print " defs\n"; 2330 imported_acl2_theorems := 2331 map (install_and_print o mk_acl2def) (!acl2_list_ref); 2332 print 2333 "Imported ACL2 stored in assignable variable imported_acl2_theorems.\n\n" 2334 end; 2335 2336(*****************************************************************************) 2337(* Print imported imported_acl2_thms, assumed installed in theory named *) 2338(* theory name, for round-trip test. *) 2339(*****************************************************************************) 2340fun print_imported_acl2_theorems theory_name file_name = 2341 let val defs = 2342 mapfilter 2343 dest_option 2344 (map (dest_acl2_thm o snd) (theorems theory_name)) 2345 in 2346 print_lisp_file 2347 file_name 2348 (fn out => map (print_acl2def out) defs) 2349 end; 2350 2351fun print_thms_to_defthms name_thm_list file_name = 2352 let val defs = map thm_to_defthm name_thm_list 2353 in 2354 print_lisp_file 2355 file_name 2356 (fn out => map (print_acl2def out) defs) 2357 end; 2358 2359(*****************************************************************************) 2360(* Add theory load time code to restore binding of acl2_simps in theory *) 2361(*****************************************************************************) 2362fun save_acl2_simps () = 2363 adjoin_to_theory 2364 {sig_ps = NONE, 2365 struct_ps = 2366 SOME(fn ppstrm => 2367 PP.add_string ppstrm 2368 ("val _ = (sexp.acl2_simps :=" 2369 ^" (!sexp.acl2_simps)@(Drule.CONJUNCTS ACL2_SIMPS));")) 2370 }; 2371 2372(*****************************************************************************) 2373(* Add theory load time code to restore binding of current_package in theory *) 2374(*****************************************************************************) 2375fun save_current_package() = 2376 adjoin_to_theory 2377 {sig_ps = NONE, 2378 struct_ps = 2379 SOME(fn ppstrm => 2380 PP.add_string ppstrm 2381 ("val _ = sexp.set_current_package \"" 2382 ^ (!current_package) ^ "\";")) 2383 }; 2384 2385(*****************************************************************************) 2386(* Add theory load time code to restore binding of acl2_names in theory. *) 2387(*****************************************************************************) 2388fun save_acl2_names () = 2389 adjoin_to_theory 2390 {sig_ps = NONE, 2391 struct_ps = 2392 SOME(fn ppstrm => 2393 PP.add_string ppstrm 2394 ("val _ = sexp.add_acl2_names " ^ 2395 string_pair_list_to_string(!acl2_names) ^ 2396 ";")) 2397 }; 2398 2399 2400(*****************************************************************************) 2401(* Add theory load time code to restore binding of string_abbrevs in theory *) 2402(*****************************************************************************) 2403fun save_string_abbrevs () = 2404 adjoin_to_theory 2405 {sig_ps = NONE, 2406 struct_ps = 2407 SOME(fn ppstrm => 2408 PP.add_string ppstrm 2409 ("val _ = sexp.add_string_abbrevs " ^ 2410 string_abbrevs_to_string(!string_abbrevs) ^ 2411 ";\n\n")) 2412 }; 2413 2414(*****************************************************************************) 2415(* Save the acl2_simps, current_package, acl2_names, acl2_hol_names, *) 2416(* string_abbrevs then export theory. *) 2417(*****************************************************************************) 2418fun export_acl2_theory () = 2419 (save_thm("ACL2_SIMPS", LIST_CONJ(!acl2_simps)); 2420 save_acl2_simps(); 2421 save_current_package(); 2422 save_acl2_names(); 2423 save_string_abbrevs(); 2424 export_theory()); 2425 2426(*****************************************************************************) 2427(* List of events processed. If two events with the same name occur,then the *) 2428(* second one is ignored. *) 2429(*****************************************************************************) 2430val event_names = ref([] : string list); 2431 2432(*****************************************************************************) 2433(* Accumulate events and discard repeats *) 2434(*****************************************************************************) 2435fun accumulate_discard_events [] = [] 2436 | accumulate_discard_events 2437 ((ev as (mlpair(_,mlpair(mlsym(_,ev_name),_)))) :: evl) = 2438 if mem ev_name (!event_names) 2439 then accumulate_discard_events evl 2440 else (event_names := ev_name :: (!event_names); 2441 ev :: accumulate_discard_events evl) 2442 | accumulate_discard_events (ev :: l) = 2443 err "accumulate_and_discard_events" "bad event"; 2444 2445 2446end