1 2open HolKernel boolLib bossLib Parse; val _ = new_theory "lisp_compiler_op"; 3 4open compilerLib decompilerLib codegenLib; 5 6open lisp_sexpTheory lisp_invTheory lisp_opsTheory lisp_bigopsTheory; 7open lisp_codegenTheory lisp_initTheory lisp_symbolsTheory 8open lisp_sexpTheory lisp_invTheory lisp_parseTheory; 9open lisp_semanticsTheory lisp_alt_semanticsTheory lisp_compilerTheory progTheory; 10 11open wordsTheory arithmeticTheory wordsLib listTheory pred_setTheory pairTheory; 12open combinTheory finite_mapTheory addressTheory helperLib sumTheory; 13open set_sepTheory bitTheory fcpTheory stringTheory optionTheory relationTheory; 14 15val _ = let 16 val thms = DB.match [] ``SPEC X64_MODEL`` 17 val thms = filter (can (find_term (can (match_term ``zLISP``))) o car o concl) (map (fst o snd) thms) 18 val thms = map (Q.INST [`ddd`|->`SOME F`,`cu`|->`NONE`]) thms 19 val _ = map (fn th => add_compiled [th] handle e => ()) thms 20 in () end; 21 22(* --- 23 24 max_print_depth := 40; 25 26*) 27 28open lisp_compilerTheory lisp_semanticsTheory; 29 30infix \\ 31val op \\ = op THEN; 32val RW = REWRITE_RULE; 33val RW1 = ONCE_REWRITE_RULE; 34 35 36val _ = set_echo 5; 37 38val PULL_EXISTS_IMP = METIS_PROVE [] ``((?x. P x) ==> Q) = (!x. P x ==> Q)``; 39val PULL_FORALL_IMP = METIS_PROVE [] ``(Q ==> !x. P x) = (!x. Q ==> P x)``; 40 41 42(* sexp2sexp *) 43 44val (_,mc_list_sfix1_def,mc_list_sfix1_pre_def) = compile "x64" `` 45 mc_list_sfix1 (x1,x2,xs) = 46 if ~isDot x2 then (x1,x2,xs) else 47 let x1 = CAR x2 in 48 let x2 = CDR x2 in 49 let x1 = SFIX x1 in 50 let xs = x1 :: xs in 51 mc_list_sfix1 (x1,x2,xs)``; 52 53val (_,mc_list_sfix2_def,mc_list_sfix2_pre_def) = compile "x64" `` 54 mc_list_sfix2 (x1,x2,xs) = 55 let x1 = HD xs in 56 let xs = TL xs in 57 if isVal x1 then (x1,x2,xs) else 58 let x1 = Dot x1 x2 in 59 let x2 = x1 in 60 mc_list_sfix2 (x1,x2,xs)`` 61 62val (_,mc_list_sfix_def,mc_list_sfix_pre_def) = compile "x64" `` 63 mc_list_sfix (x1,x2,xs) = 64 let xs = x1::xs in 65 let x1 = Val 0 in 66 let xs = x1::xs in 67 let (x1,x2,xs) = mc_list_sfix1 (x1,x2,xs) in 68 let x2 = Sym "NIL" in 69 let (x1,x2,xs) = mc_list_sfix2 (x1,x2,xs) in 70 let x1 = HD xs in 71 let xs = TL xs in 72 (x1,x2,xs)``; 73 74val SFIX_sfix = prove( 75 ``SFIX = sfix``, 76 SIMP_TAC std_ss [FUN_EQ_THM] \\ Cases \\ EVAL_TAC); 77 78val mc_list_sfix1_thm = prove( 79 ``!x2 x1 xs. 80 ?y1 y2. mc_list_sfix1_pre (x1,x2,xs) /\ 81 (mc_list_sfix1 (x1,x2,xs) = 82 (y1,y2,REVERSE (MAP sfix (sexp2list x2)) ++ xs))``, 83 REVERSE Induct \\ ONCE_REWRITE_TAC [mc_list_sfix1_def,mc_list_sfix1_pre_def] 84 \\ FULL_SIMP_TAC std_ss [LET_DEF,isDot_def,sexp2list_def,MAP,APPEND,CAR_def,CDR_def,REVERSE_DEF] 85 \\ REPEAT STRIP_TAC 86 \\ POP_ASSUM (STRIP_ASSUME_TAC o Q.SPECL [`SFIX x2`,`SFIX x2::xs`]) 87 \\ ASM_SIMP_TAC std_ss [GSYM APPEND_ASSOC,APPEND,SFIX_sfix]); 88 89val isVal_SFIX = prove(``!x. ~isVal (SFIX x)``, Cases \\ EVAL_TAC); 90 91val mc_list_sfix2_thm = prove( 92 ``!ys zs x1 xs. 93 mc_list_sfix2_pre (x1,list2sexp zs,MAP SFIX ys ++ Val 0 :: xs) /\ 94 (mc_list_sfix2 (x1,list2sexp zs,MAP SFIX ys ++ Val 0 :: xs) = 95 (Val 0, list2sexp (REVERSE (MAP SFIX ys) ++ zs), xs))``, 96 Induct \\ ONCE_REWRITE_TAC [mc_list_sfix2_def,mc_list_sfix2_pre_def] 97 \\ SIMP_TAC (srw_ss()) [APPEND,REVERSE_DEF,HD,TL,LET_DEF,isVal_def,isVal_SFIX] 98 \\ REPEAT STRIP_TAC 99 \\ ASM_SIMP_TAC std_ss [GSYM list2sexp_def] 100 \\ SIMP_TAC std_ss [APPEND,GSYM APPEND_ASSOC]); 101 102val mc_list_sfix_thm = prove( 103 ``mc_list_sfix_pre (x1,x2,xs) /\ 104 (mc_list_sfix (x1,x2,xs) = (x1,list2sexp (MAP sfix (sexp2list x2)),xs))``, 105 SIMP_TAC std_ss [mc_list_sfix_def,mc_list_sfix_pre_def,LET_DEF] 106 \\ STRIP_ASSUME_TAC (Q.SPECL [`x2`,`Val 0`,`Val 0::x1::xs`] mc_list_sfix1_thm) 107 \\ FULL_SIMP_TAC std_ss [GSYM rich_listTheory.MAP_REVERSE] 108 \\ ASM_SIMP_TAC std_ss [mc_list_sfix2_thm,GSYM SFIX_sfix,GSYM list2sexp_def] 109 \\ FULL_SIMP_TAC std_ss [GSYM rich_listTheory.MAP_REVERSE,TL,HD,REVERSE_REVERSE] 110 \\ FULL_SIMP_TAC (srw_ss()) [APPEND_NIL]); 111 112(* push list of args to sexp2sexp *) 113 114val (_,mc_push_list_def,mc_push_list_pre_def) = compile "x64" `` 115 mc_push_list (x0,x2,xs) = 116 if ~isDot x2 then 117 let x0 = Sym "NIL" in 118 let x2 = Sym "NIL" in 119 (x0,x2,xs) 120 else 121 let x0 = CAR x2 in 122 let x2 = CDR x2 in 123 let xs = x0 :: xs in 124 let x0 = Sym "EQUAL" in 125 let xs = x0 :: xs in 126 mc_push_list (x0,x2,xs)`` 127 128val push_list_fun_def = Define ` 129 (push_list_fun [] = []) /\ 130 (push_list_fun (x::xs) = Sym "EQUAL" :: x :: push_list_fun xs)`; 131 132val push_list_fun_SNOC = prove( 133 ``!xs x. push_list_fun (xs ++ [x]) = push_list_fun xs ++ [Sym "EQUAL"; x]``, 134 Induct \\ ASM_SIMP_TAC std_ss [push_list_fun_def,APPEND]); 135 136val mc_push_list_thm = prove( 137 ``!x2 x0 xs. 138 mc_push_list_pre (x0,x2,xs) /\ 139 (mc_push_list (x0,x2,xs) = 140 (Sym "NIL",Sym "NIL",push_list_fun (REVERSE (sexp2list x2)) ++ xs))``, 141 REVERSE Induct \\ ONCE_REWRITE_TAC [mc_push_list_pre_def,mc_push_list_def] 142 THEN1 (EVAL_TAC \\ SIMP_TAC std_ss []) 143 THEN1 (EVAL_TAC \\ SIMP_TAC std_ss []) 144 \\ ASM_SIMP_TAC std_ss [isDot_def,LET_DEF,sexp2list_def,REVERSE_DEF,CDR_def,CAR_def] 145 \\ ASM_SIMP_TAC std_ss [push_list_fun_SNOC,GSYM APPEND_ASSOC,APPEND]); 146 147val (_,mc_sexp2sexp_aux_def,mc_sexp2sexp_aux_pre_def) = compile "x64" `` 148 mc_sexp2sexp_aux (x0,x1,x2,xs:SExp list) = 149 if x0 = Sym "NIL" then (* eval *) 150 if x2 = Sym "NIL" then 151 let x1 = Sym "NIL" in 152 let x0 = Sym "QUOTE" in 153 let x2 = Dot x2 x1 in 154 let x0 = Dot x0 x2 in 155 let x2 = x0 in 156 let x0 = Sym "T" in 157 (x0,x1,x2,xs) 158 else if x2 = Sym "T" then 159 let x1 = Sym "NIL" in 160 let x0 = Sym "QUOTE" in 161 let x2 = Dot x2 x1 in 162 let x0 = Dot x0 x2 in 163 let x2 = x0 in 164 let x0 = Sym "T" in 165 (x0,x1,x2,xs) 166 else if isVal x2 then 167 let x1 = Sym "NIL" in 168 let x0 = Sym "QUOTE" in 169 let x2 = Dot x2 x1 in 170 let x0 = Dot x0 x2 in 171 let x2 = x0 in 172 let x0 = Sym "T" in 173 (x0,x1,x2,xs) 174 else if isSym x2 then 175 let x1 = Sym "NIL" in 176 let x0 = Sym "T" in 177 (x0,x1,x2,xs) 178 else let x0 = SAFE_CAR x2 in 179 if x0 = Sym "QUOTE" then 180 let x2 = SAFE_CDR x2 in 181 let x2 = SAFE_CAR x2 in 182 let x1 = Sym "NIL" in 183 let x0 = Sym "QUOTE" in 184 let x2 = Dot x2 x1 in 185 let x0 = Dot x0 x2 in 186 let x2 = x0 in 187 let x0 = Sym "T" in 188 (x0,x1,x2,xs) 189 else if x0 = Sym "IF" then 190 let xs = x0 :: xs in 191 let x0 = Sym "CONSP" in 192 let xs = x0 :: xs in 193 let x2 = SAFE_CDR x2 in 194 let x0 = SAFE_CAR x2 in 195 let xs = x0 :: xs in 196 let x0 = Sym "EQUAL" in 197 let xs = x0 :: xs in 198 let x2 = SAFE_CDR x2 in 199 let x0 = SAFE_CAR x2 in 200 let xs = x0 :: xs in 201 let x0 = Sym "EQUAL" in 202 let xs = x0 :: xs in 203 let x2 = SAFE_CDR x2 in 204 let x0 = SAFE_CAR x2 in 205 let xs = x0 :: xs in 206 let x0 = Sym "EQUAL" in 207 let xs = x0 :: xs in 208 let x2 = Sym "NIL" in 209 let x0 = Sym "LIST" in 210 (x0,x1,x2,xs) 211 else if x0 = Sym "FIRST" then 212 let xs = x0 :: xs in 213 let x0 = Sym "CONS" in 214 let xs = x0 :: xs in 215 let x2 = SAFE_CDR x2 in 216 let x2 = SAFE_CAR x2 in 217 let x0 = Sym "NIL" in 218 (x0,x1,x2,xs) 219 else if x0 = Sym "SECOND" then 220 let xs = x0 :: xs in 221 let x0 = Sym "CONS" in 222 let xs = x0 :: xs in 223 let x2 = SAFE_CDR x2 in 224 let x2 = SAFE_CAR x2 in 225 let x0 = Sym "NIL" in 226 (x0,x1,x2,xs) 227 else if x0 = Sym "THIRD" then 228 let xs = x0 :: xs in 229 let x0 = Sym "CONS" in 230 let xs = x0 :: xs in 231 let x2 = SAFE_CDR x2 in 232 let x2 = SAFE_CAR x2 in 233 let x0 = Sym "NIL" in 234 (x0,x1,x2,xs) 235 else if x0 = Sym "FOURTH" then 236 let xs = x0 :: xs in 237 let x0 = Sym "CONS" in 238 let xs = x0 :: xs in 239 let x2 = SAFE_CDR x2 in 240 let x2 = SAFE_CAR x2 in 241 let x0 = Sym "NIL" in 242 (x0,x1,x2,xs) 243 else if x0 = Sym "FIFTH" then 244 let xs = x0 :: xs in 245 let x0 = Sym "CONS" in 246 let xs = x0 :: xs in 247 let x2 = SAFE_CDR x2 in 248 let x2 = SAFE_CAR x2 in 249 let x0 = Sym "NIL" in 250 (x0,x1,x2,xs) 251 else let x0 = SAFE_CAR x0 in if x0 = Sym "LAMBDA" then 252 let x1 = SAFE_CDR x2 in 253 let xs = x1 :: xs in 254 let x2 = SAFE_CAR x2 in 255 let x2 = SAFE_CDR x2 in 256 let x1 = SAFE_CDR x2 in 257 let x2 = SAFE_CAR x2 in 258 let (x1,x2,xs) = mc_list_sfix (x1,x2,xs) in 259 let xs = x2 :: xs in 260 let x2 = SAFE_CAR x1 in 261 let xs = x0 :: xs in 262 let x0 = Sym "NIL" in 263 (x0,x1,x2,xs) 264 else let x0 = SAFE_CAR x2 in if x0 = Sym "COND" then 265 let xs = x0 :: xs in 266 let xs = x0 :: xs in 267 let x2 = SAFE_CDR x2 in 268 let (x0,x2,xs) = mc_push_list (x0,x2,xs) in 269 let x2 = Sym "NIL" in 270 let x0 = Sym "COND" in 271 (x0,x1,x2,xs) 272 else let x0 = SAFE_CAR x2 in if x0 = Sym "LET" then 273 let xs = x2 :: xs in 274 let x0 = Val 1 in 275 let xs = x0 :: xs in 276 let x2 = SAFE_CDR x2 in 277 let x2 = SAFE_CAR x2 in 278 let (x0,x2,xs) = mc_push_list (x0,x2,xs) in 279 let x2 = Sym "NIL" in 280 let x0 = Sym "LET" in 281 (x0,x1,x2,xs) 282 else let x0 = SAFE_CAR x2 in if x0 = Sym "LET*" then 283 let xs = x2 :: xs in 284 let x0 = Val 1 in 285 let xs = x0 :: xs in 286 let x2 = SAFE_CDR x2 in 287 let x2 = SAFE_CAR x2 in 288 let (x0,x2,xs) = mc_push_list (x0,x2,xs) in 289 let x2 = Sym "NIL" in 290 let x0 = Sym "LET" in 291 (x0,x1,x2,xs) 292 else if x0 = Sym "DEFUN" then 293 let x1 = x2 in 294 let x1 = SAFE_CDR x1 in 295 let x2 = SAFE_CAR x1 in 296 let x2 = SFIX x2 in 297 let xs = x2 :: xs in 298 let x1 = SAFE_CDR x1 in 299 let x2 = SAFE_CAR x1 in 300 let (x1,x2,xs) = mc_list_sfix (x1,x2,xs) in 301 let xs = x2 :: xs in 302 let x1 = SAFE_CDR x1 in 303 let x2 = SAFE_CAR x1 in 304 let x1 = Sym "NIL" in 305 let x2 = Dot x2 x1 in 306 let x1 = x2 in 307 let x2 = HD xs in 308 let xs = TL xs in 309 let x2 = Dot x2 x1 in 310 let x1 = x2 in 311 let x2 = HD xs in 312 let xs = TL xs in 313 let x2 = Dot x2 x1 in 314 let x0 = Dot x0 x2 in 315 let x2 = x0 in 316 let x0 = Sym "T" in 317 let x1 = Sym "NIL" in 318 (x0,x1,x2,xs) 319 else 320 let x2 = SAFE_CDR x2 in 321 let x0 = SFIX x0 in 322 let xs = x0 :: xs in 323 let x0 = Sym "CONSP" in 324 let xs = x0 :: xs in 325 let (x0,x2,xs) = mc_push_list (x0,x2,xs) in 326 let x2 = Sym "NIL" in 327 let x0 = Sym "LIST" in 328 (x0,x1,x2,xs) 329 else if x0 = Sym "LIST" then 330 let x0 = HD xs in 331 let xs = TL xs in 332 let x1 = HD xs in 333 let xs = TL xs in 334 if x0 = Sym "EQUAL" then 335 let xs = x2 :: xs in 336 let x2 = x1 in 337 let x0 = Sym "LIST" in 338 let xs = x0 :: xs in 339 let x0 = Sym "NIL" in 340 (x0,x1,x2,xs) 341 else 342 let x1 = Dot x1 x2 in 343 let x2 = x1 in 344 let x0 = Sym "T" in 345 let x1 = Sym "NIL" in 346 (x0,x1,x2,xs) 347 else if x0 = Sym "LET" then 348 let x0 = HD xs in 349 let xs = TL xs in 350 let x1 = HD xs in 351 let xs = TL xs in 352 if x0 = Sym "EQUAL" then 353 let xs = x2 :: xs in 354 let x2 = SAFE_CDR x1 in 355 let x2 = SAFE_CAR x2 in 356 let x0 = SAFE_CAR x1 in 357 let xs = x0 :: xs in 358 let x0 = Sym "LET" in 359 let xs = x0 :: xs in 360 let x0 = Sym "NIL" in 361 (x0,x1,x2,xs) 362 else 363 let x0 = SAFE_CAR x1 in 364 let xs = x0 :: xs in 365 let xs = x2 :: xs in 366 let x2 = Val 1 in 367 let xs = x2 :: xs in 368 let x1 = SAFE_CDR x1 in 369 let x1 = SAFE_CDR x1 in 370 let x2 = SAFE_CAR x1 in 371 let x0 = Sym "NIL" in 372 (x0,x1,x2,xs) 373 else if x0 = Sym "COND" then 374 let x0 = HD xs in 375 let xs = TL xs in 376 let x1 = HD xs in 377 let xs = TL xs in 378 if x0 = Sym "EQUAL" then 379 let xs = x2 :: xs in 380 let x0 = Sym "COND" in 381 let xs = x0 :: xs in 382 let xs = x0 :: xs in 383 let x0 = Sym "CONSP" in 384 let xs = x0 :: xs in 385 let x0 = SAFE_CAR x1 in 386 let xs = x0 :: xs in 387 let x0 = Sym "EQUAL" in 388 let xs = x0 :: xs in 389 let x2 = SAFE_CDR x1 in 390 let x0 = SAFE_CAR x2 in 391 let xs = x0 :: xs in 392 let x0 = Sym "EQUAL" in 393 let xs = x0 :: xs in 394 let x2 = Sym "NIL" in 395 let x0 = Sym "LIST" in 396 (x0,x1,x2,xs) 397 else 398 let x1 = Dot x1 x2 in 399 let x2 = x1 in 400 let x1 = Sym "NIL" in 401 let x0 = Sym "T" in 402 (x0,x1,x2,xs) 403 else if x0 = Sym "T" then (* continue / return *) 404 let x0 = HD xs in 405 let xs = TL xs in 406 if x0 = Sym "NIL" then 407 let x0 = Sym "FIRST" in 408 (x0,x1,x2,xs) 409 else if x0 = Sym "CONS" then 410 let x0 = HD xs in 411 let xs = TL xs in 412 let x1 = Sym "NIL" in 413 let x2 = Dot x2 x1 in 414 let x0 = Dot x0 x2 in 415 let x2 = x0 in 416 let x0 = Sym "T" in 417 (x0,x1,x2,xs) 418 else if x0 = Sym "LIST" then 419 let x0 = HD xs in 420 let xs = TL xs in 421 let x2 = Dot x2 x0 in 422 let x0 = Sym "LIST" in 423 (x0,x1,x2,xs) 424 else if x0 = Sym "COND" then 425 let x0 = HD xs in 426 let xs = TL xs in 427 let x2 = CDR x2 in 428 let x2 = Dot x2 x0 in 429 let x0 = Sym "COND" in 430 (x0,x1,x2,xs) 431 else if x0 = Sym "LET" then 432 let x0 = Sym "NIL" in 433 let x2 = Dot x2 x0 in 434 let x0 = HD xs in 435 let xs = TL xs in 436 let x0 = SFIX x0 in 437 let x0 = Dot x0 x2 in 438 let x2 = HD xs in 439 let xs = TL xs in 440 let x0 = Dot x0 x2 in 441 let x2 = x0 in 442 let x0 = Sym "LET" in 443 (x0,x1,x2,xs) 444 else if x0 = Val 1 then (* final case for let *) 445 let x1 = Sym "NIL" in 446 let x2 = Dot x2 x1 in 447 let x1 = HD xs in 448 let xs = TL xs in 449 let x1 = Dot x1 x2 in 450 let x2 = HD xs in 451 let xs = TL xs in 452 let x2 = Dot x2 x1 in 453 let x1 = Sym "NIL" in 454 let x0 = Sym "T" in 455 (x0,x1,x2,xs) 456 else if x0 = Sym "LAMBDA" then 457 let x1 = Sym "NIL" in 458 let x2 = Dot x2 x1 in 459 let x1 = HD xs in 460 let xs = TL xs in 461 let x1 = Dot x1 x2 in 462 let x0 = Dot x0 x1 in 463 let x2 = HD xs in 464 let xs = TL xs in 465 let xs = x0 :: xs in 466 let x0 = Sym "CONSP" in 467 let xs = x0 :: xs in 468 let (x0,x2,xs) = mc_push_list (x0,x2,xs) in 469 let x1 = Sym "NIL" in 470 let x2 = Sym "NIL" in 471 let x0 = Sym "LIST" in 472 (x0,x1,x2,xs) 473 else (x0,x1,x2,xs) 474 else 475 let x0 = Sym "FIRST" in (x0,x1,x2,xs)``; 476 477val (_,mc_sexp2sexp_loop_def,mc_sexp2sexp_loop_pre_def) = compile "x64" `` 478 mc_sexp2sexp_loop (x0,x1,x2,xs) = 479 if x0 = Sym "FIRST" then (x0,x1,x2,xs) else 480 let (x0,x1,x2,xs) = mc_sexp2sexp_aux (x0,x1,x2,xs) in 481 mc_sexp2sexp_loop (x0,x1,x2,xs)`` 482 483val (_,mc_sexp2sexp_def,mc_sexp2sexp_pre_def) = compile "x64" `` 484 mc_sexp2sexp (x0,x1,x2,xs) = 485 let xs = x0 :: xs in 486 let xs = x1 :: xs in 487 let x0 = Sym "NIL" in 488 let xs = x0 :: xs in 489 let (x0,x1,x2,xs) = mc_sexp2sexp_loop (x0,x1,x2,xs) in 490 let x1 = HD xs in 491 let xs = TL xs in 492 let x0 = HD xs in 493 let xs = TL xs in 494 (x0,x1,x2,xs)``; 495 496 497val CAR_LESS_SUC = prove( 498 ``!x. LSIZE x < SUC n ==> LSIZE (CAR x) < SUC n``, 499 Cases_on `x` \\ EVAL_TAC \\ DECIDE_TAC); 500 501val CDR_LESS_SUC = prove( 502 ``!x. LSIZE x < SUC n ==> LSIZE (CDR x) < SUC n``, 503 Cases_on `x` \\ EVAL_TAC \\ DECIDE_TAC); 504 505val LSIZE_EVERY_sexp2list = prove( 506 ``!x3 x2. LSIZE x3 < LSIZE x2 ==> EVERY (\x. LSIZE x < LSIZE x2) (sexp2list x3)``, 507 REVERSE Induct \\ ASM_SIMP_TAC std_ss [EVERY_DEF,sexp2list_def] 508 \\ REPEAT STRIP_TAC \\ FULL_SIMP_TAC std_ss [LSIZE_def] THEN1 DECIDE_TAC 509 \\ `LSIZE x3' < LSIZE x2` by DECIDE_TAC \\ FULL_SIMP_TAC std_ss []); 510 511val LSIZE_CAR_LESS_EQ = prove( 512 ``!x. LSIZE (CAR x) <= LSIZE x /\ LSIZE (CDR x) <= LSIZE x``, 513 Cases \\ SIMP_TAC std_ss [CAR_def,CDR_def,LSIZE_def] \\ DECIDE_TAC); 514 515val mc_sexp2sexp_loop_alt = 516 SIMP_RULE std_ss [mc_sexp2sexp_aux_pre_def,mc_sexp2sexp_aux_def, 517 mc_push_list_thm,LET_DEF,mc_list_sfix_thm] mc_sexp2sexp_loop_def 518 519val mc_sexp2sexp_loop_pre_alt = 520 SIMP_RULE std_ss [mc_sexp2sexp_aux_pre_def,mc_sexp2sexp_aux_def, 521 mc_push_list_thm,LET_DEF,mc_list_sfix_thm] mc_sexp2sexp_loop_pre_def 522 523val mc_sexp2sexp_loop_lemma = prove( 524 ``!x2 x1 xs. 525 (mc_sexp2sexp_loop_pre (Sym "NIL",x1,x2,xs) = 526 mc_sexp2sexp_loop_pre (Sym "T",Sym "NIL",sexp2sexp x2,xs)) /\ 527 (mc_sexp2sexp_loop (Sym "NIL",x1,x2,xs) = 528 mc_sexp2sexp_loop (Sym "T",Sym "NIL",sexp2sexp x2,xs))``, 529 STRIP_TAC \\ completeInduct_on `LSIZE x2` \\ NTAC 4 STRIP_TAC 530 \\ FULL_SIMP_TAC std_ss [PULL_FORALL_IMP] 531 \\ SIMP_TAC std_ss [Once mc_sexp2sexp_loop_pre_alt] 532 \\ SIMP_TAC std_ss [Once mc_sexp2sexp_loop_alt] 533 \\ ONCE_REWRITE_TAC [sexp2sexp_def] 534 \\ Cases_on `x2 = Sym "NIL"` THEN1 FULL_SIMP_TAC (srw_ss()) [LET_DEF,list2sexp_def] 535 \\ Cases_on `x2 = Sym "T"` THEN1 FULL_SIMP_TAC (srw_ss()) [LET_DEF,list2sexp_def] 536 \\ Cases_on `isVal x2` THEN1 FULL_SIMP_TAC (srw_ss()) [LET_DEF,list2sexp_def] 537 \\ Cases_on `isSym x2` THEN1 FULL_SIMP_TAC (srw_ss()) [LET_DEF,list2sexp_def] 538 \\ FULL_SIMP_TAC std_ss [LET_DEF,SAFE_CAR_def,SAFE_CDR_def] 539 \\ Cases_on `CAR x2 = Sym "QUOTE"` \\ FULL_SIMP_TAC std_ss [] 540 THEN1 FULL_SIMP_TAC (srw_ss()) [LET_DEF,list2sexp_def] 541 \\ `LSIZE (CDR x2) < LSIZE x2 /\ 542 LSIZE (CAR (CDR x2)) < LSIZE x2 /\ 543 LSIZE (CAR (CDR (CDR x2))) < LSIZE x2 /\ 544 LSIZE (CAR (CDR (CDR (CDR x2)))) < LSIZE x2` by 545 (Cases_on `x2` \\ FULL_SIMP_TAC std_ss [isVal_def,isSym_def,CDR_def,LSIZE_def] 546 \\ REPEAT STRIP_TAC 547 \\ REPEAT (MATCH_MP_TAC CAR_LESS_SUC ORELSE MATCH_MP_TAC CDR_LESS_SUC) 548 \\ DECIDE_TAC) 549 \\ Cases_on `CAR x2 = Sym "FIRST"` \\ FULL_SIMP_TAC std_ss [] THEN1 550 (FULL_SIMP_TAC (srw_ss()) [] 551 \\ FULL_SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,HD,list2sexp_def] 552 \\ FULL_SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,HD,list2sexp_def]) 553 \\ Cases_on `CAR x2 = Sym "SECOND"` \\ FULL_SIMP_TAC std_ss [] THEN1 554 (FULL_SIMP_TAC (srw_ss()) [] 555 \\ FULL_SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,HD,list2sexp_def] 556 \\ FULL_SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,HD,list2sexp_def]) 557 \\ Cases_on `CAR x2 = Sym "THIRD"` \\ FULL_SIMP_TAC std_ss [] THEN1 558 (FULL_SIMP_TAC (srw_ss()) [] 559 \\ FULL_SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,HD,list2sexp_def] 560 \\ FULL_SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,HD,list2sexp_def]) 561 \\ Cases_on `CAR x2 = Sym "FOURTH"` \\ FULL_SIMP_TAC std_ss [] THEN1 562 (FULL_SIMP_TAC (srw_ss()) [] 563 \\ FULL_SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,HD,list2sexp_def] 564 \\ FULL_SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,HD,list2sexp_def]) 565 \\ Cases_on `CAR x2 = Sym "FIFTH"` \\ FULL_SIMP_TAC std_ss [] THEN1 566 (FULL_SIMP_TAC (srw_ss()) [] 567 \\ FULL_SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,HD,list2sexp_def] 568 \\ FULL_SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,HD,list2sexp_def]) 569 \\ Cases_on `CAR x2 = Sym "IF"` \\ FULL_SIMP_TAC std_ss [list2sexp_def] THEN1 570 (FULL_SIMP_TAC (srw_ss()) [] 571 \\ NTAC 10 (SIMP_TAC std_ss [Once mc_sexp2sexp_loop_alt] 572 \\ SIMP_TAC std_ss [Once mc_sexp2sexp_loop_pre_alt] 573 \\ FULL_SIMP_TAC (srw_ss()) [LET_DEF,HD,list2sexp_def])) 574 \\ Cases_on `CAR x2 = Sym "DEFUN"` \\ FULL_SIMP_TAC (srw_ss()) [mc_list_sfix_thm,CAR_def] 575 THEN1 (FULL_SIMP_TAC std_ss [HD,TL,SFIX_sfix]) 576 \\ FULL_SIMP_TAC std_ss [mc_push_list_thm] 577 \\ `!x1 x3 xs x zs. 578 LSIZE x3 < LSIZE x2 ==> 579 (mc_sexp2sexp_loop_pre (Sym "LIST",x1,list2sexp zs, 580 push_list_fun (REVERSE (sexp2list x3)) ++ Sym "CONSP"::x::xs) = 581 mc_sexp2sexp_loop_pre (Sym "T",Sym "NIL", 582 list2sexp (x::MAP (\a. sexp2sexp a) (sexp2list x3) ++ zs),xs)) /\ 583 (mc_sexp2sexp_loop (Sym "LIST",x1,list2sexp zs, 584 push_list_fun (REVERSE (sexp2list x3)) ++ Sym "CONSP"::x::xs) = 585 mc_sexp2sexp_loop (Sym "T",Sym "NIL", 586 list2sexp (x::MAP (\a. sexp2sexp a) (sexp2list x3) ++ zs),xs))` by 587 (REPEAT STRIP_TAC 588 \\ `EVERY (\x. LSIZE x < LSIZE x2) (sexp2list x3)` by METIS_TAC [LSIZE_EVERY_sexp2list] 589 \\ POP_ASSUM MP_TAC 590 \\ Q.SPEC_TAC (`x1`,`x1`) 591 \\ Q.SPEC_TAC (`zs`,`zs`) 592 \\ SIMP_TAC std_ss [] 593 \\ `sexp2list x3 = REVERSE (REVERSE (sexp2list x3))` by METIS_TAC [REVERSE_REVERSE] 594 \\ POP_ASSUM (fn th => ONCE_REWRITE_TAC [th]) 595 \\ Q.SPEC_TAC (`REVERSE (sexp2list x3)`,`ys`) 596 \\ SIMP_TAC std_ss [REVERSE_REVERSE] 597 \\ Induct THEN1 598 (SIMP_TAC std_ss [push_list_fun_def,APPEND,REVERSE_DEF,EVERY_DEF,MAP] 599 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,list2sexp_def] 600 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,list2sexp_def]) 601 \\ SIMP_TAC std_ss [push_list_fun_def,APPEND,REVERSE_DEF,EVERY_DEF,MAP] 602 \\ SIMP_TAC std_ss [MAP_APPEND,MAP,APPEND,GSYM APPEND_ASSOC,EVERY_APPEND,EVERY_DEF] 603 \\ REPEAT STRIP_TAC 604 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,list2sexp_def] 605 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,list2sexp_def] 606 \\ ASM_SIMP_TAC std_ss [] 607 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,list2sexp_def] 608 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,list2sexp_def] 609 \\ SIMP_TAC std_ss [GSYM list2sexp_def] 610 \\ ASM_SIMP_TAC std_ss [] \\ ASM_SIMP_TAC std_ss [list2sexp_def,APPEND]) 611 \\ Cases_on `CAR (CAR x2) = Sym "LAMBDA"` \\ ASM_SIMP_TAC std_ss [] THEN1 612 (`LSIZE (CAR (CDR (CDR (CAR x2)))) < LSIZE x2` by 613 (Cases_on `x2` \\ FULL_SIMP_TAC std_ss [isVal_def,isSym_def,CDR_def,LSIZE_def,CAR_def] 614 \\ REPEAT STRIP_TAC 615 \\ REPEAT (MATCH_MP_TAC CAR_LESS_SUC ORELSE MATCH_MP_TAC CDR_LESS_SUC) 616 \\ DECIDE_TAC) 617 \\ ASM_SIMP_TAC std_ss [] 618 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,mc_push_list_thm] 619 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,mc_push_list_thm] 620 \\ `LSIZE (CDR x2) < LSIZE x2` by 621 (Cases_on `x2` \\ EVAL_TAC \\ FULL_SIMP_TAC std_ss [isVal_def,isSym_def] \\ DECIDE_TAC) 622 \\ FULL_SIMP_TAC std_ss [GSYM list2sexp_def,APPEND_NIL]) 623 \\ Cases_on `CAR x2 = Sym "COND"` \\ ASM_SIMP_TAC std_ss [] THEN1 624 (FULL_SIMP_TAC std_ss [GSYM list2sexp_def] 625 \\ `!x1 x3 xs x zs. 626 LSIZE x3 < LSIZE x2 ==> 627 (mc_sexp2sexp_loop_pre (Sym "COND",x1,list2sexp zs, 628 push_list_fun (REVERSE (sexp2list x3)) ++ 629 Sym "COND"::Sym "COND"::xs) = 630 mc_sexp2sexp_loop_pre (Sym "T",Sym "NIL", 631 list2sexp (Sym "COND":: 632 MAP (\a. list2sexp [sexp2sexp (CAR a); sexp2sexp (CAR (CDR a))]) 633 (sexp2list x3) ++ zs),xs)) /\ 634 (mc_sexp2sexp_loop (Sym "COND",x1,list2sexp zs, 635 push_list_fun (REVERSE (sexp2list x3)) ++ 636 Sym "COND"::Sym "COND"::xs) = 637 mc_sexp2sexp_loop (Sym "T",Sym "NIL", 638 list2sexp (Sym "COND":: 639 MAP (\a. list2sexp [sexp2sexp (CAR a); sexp2sexp (CAR (CDR a))]) 640 (sexp2list x3) ++ zs),xs))` suffices_by (STRIP_TAC THEN Q.PAT_X_ASSUM `LSIZE (CDR x2) < LSIZE x2` ASSUME_TAC 641 \\ FULL_SIMP_TAC std_ss [list2sexp_def,APPEND_NIL]) 642 \\ NTAC 6 STRIP_TAC 643 \\ `EVERY (\x. LSIZE x < LSIZE x2) (sexp2list x3)` by METIS_TAC [LSIZE_EVERY_sexp2list] 644 \\ POP_ASSUM MP_TAC \\ POP_ASSUM MP_TAC 645 \\ Q.SPEC_TAC (`x1`,`x1`) 646 \\ Q.SPEC_TAC (`zs`,`zs`) 647 \\ SIMP_TAC std_ss [] 648 \\ `sexp2list x3 = REVERSE (REVERSE (sexp2list x3))` by METIS_TAC [REVERSE_REVERSE] 649 \\ POP_ASSUM (fn th => ONCE_REWRITE_TAC [th]) 650 \\ Q.SPEC_TAC (`REVERSE (sexp2list x3)`,`ys`) 651 \\ SIMP_TAC std_ss [REVERSE_REVERSE] 652 \\ Induct THEN1 653 (SIMP_TAC std_ss [push_list_fun_def,APPEND,REVERSE_DEF,EVERY_DEF,MAP] 654 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,list2sexp_def] 655 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,list2sexp_def]) 656 \\ SIMP_TAC std_ss [push_list_fun_def,APPEND,REVERSE_DEF,EVERY_DEF,MAP] 657 \\ SIMP_TAC std_ss [MAP_APPEND,MAP,APPEND,GSYM APPEND_ASSOC,EVERY_APPEND,EVERY_DEF] 658 \\ NTAC 5 STRIP_TAC 659 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,list2sexp_def] 660 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,list2sexp_def] 661 \\ SIMP_TAC std_ss [SAFE_CAR_def,SAFE_CDR_def] 662 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,list2sexp_def] 663 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,list2sexp_def] 664 \\ `LSIZE (CAR (CDR h)) < LSIZE x2 /\ LSIZE (CAR h) < LSIZE x2` by 665 (REPEAT STRIP_TAC \\ MATCH_MP_TAC LESS_EQ_LESS_TRANS 666 \\ Q.EXISTS_TAC `LSIZE h` \\ ASM_SIMP_TAC std_ss [] 667 \\ METIS_TAC [LSIZE_CAR_LESS_EQ,LESS_EQ_TRANS]) 668 \\ FULL_SIMP_TAC std_ss [list2sexp_def] 669 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,list2sexp_def] 670 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,list2sexp_def] 671 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,list2sexp_def] 672 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,list2sexp_def] 673 \\ ASM_SIMP_TAC std_ss [] 674 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,list2sexp_def] 675 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,list2sexp_def] 676 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,list2sexp_def] 677 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,list2sexp_def] 678 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,list2sexp_def,CDR_def] 679 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,list2sexp_def,CDR_def] 680 \\ SIMP_TAC std_ss [GSYM list2sexp_def] \\ ASM_SIMP_TAC std_ss [] 681 \\ SIMP_TAC std_ss [list2sexp_def,MAP,MAP_APPEND,APPEND,isDot_def]) 682 \\ `!x1 x3 xs x zs. 683 LSIZE x3 < LSIZE x2 ==> 684 (mc_sexp2sexp_loop_pre (Sym "LET",x1,list2sexp zs, 685 push_list_fun (REVERSE (sexp2list x3)) ++ Val 1::x2::xs) = 686 mc_sexp2sexp_loop_pre (Sym "T",Sym "NIL", 687 list2sexp [CAR x2; list2sexp (MAP (\a. list2sexp 688 [sfix (CAR a); sexp2sexp (CAR (CDR a))]) (sexp2list x3) ++ zs); 689 sexp2sexp (CAR (CDR (CDR x2)))],xs)) /\ 690 (mc_sexp2sexp_loop (Sym "LET",x1,list2sexp zs, 691 push_list_fun (REVERSE (sexp2list x3)) ++ Val 1::x2::xs) = 692 mc_sexp2sexp_loop (Sym "T",Sym "NIL", 693 list2sexp [CAR x2; list2sexp (MAP (\a. list2sexp 694 [sfix (CAR a); sexp2sexp (CAR (CDR a))]) (sexp2list x3) ++ zs); 695 sexp2sexp (CAR (CDR (CDR x2)))],xs))` by 696 (NTAC 6 STRIP_TAC 697 \\ `EVERY (\x. LSIZE x < LSIZE x2) (sexp2list x3)` by METIS_TAC [LSIZE_EVERY_sexp2list] 698 \\ POP_ASSUM MP_TAC \\ POP_ASSUM MP_TAC 699 \\ Q.SPEC_TAC (`x1`,`x1`) 700 \\ Q.SPEC_TAC (`zs`,`zs`) 701 \\ SIMP_TAC std_ss [] 702 \\ `sexp2list x3 = REVERSE (REVERSE (sexp2list x3))` by METIS_TAC [REVERSE_REVERSE] 703 \\ POP_ASSUM (fn th => ONCE_REWRITE_TAC [th]) 704 \\ Q.SPEC_TAC (`REVERSE (sexp2list x3)`,`ys`) 705 \\ SIMP_TAC std_ss [REVERSE_REVERSE] 706 \\ Induct THEN1 707 (SIMP_TAC std_ss [push_list_fun_def,APPEND,REVERSE_DEF,EVERY_DEF,MAP] 708 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,list2sexp_def] 709 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,list2sexp_def] 710 \\ SIMP_TAC std_ss [SAFE_CAR_def,SAFE_CDR_def] 711 \\ ASM_SIMP_TAC std_ss [] 712 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,list2sexp_def] 713 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,list2sexp_def]) 714 \\ SIMP_TAC std_ss [push_list_fun_def,APPEND,REVERSE_DEF,EVERY_DEF,MAP] 715 \\ SIMP_TAC std_ss [MAP_APPEND,MAP,APPEND,GSYM APPEND_ASSOC,EVERY_APPEND,EVERY_DEF] 716 \\ NTAC 5 STRIP_TAC 717 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,list2sexp_def] 718 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,list2sexp_def] 719 \\ `LSIZE (CAR (CDR h)) < LSIZE x2` by 720 (REPEAT STRIP_TAC \\ MATCH_MP_TAC LESS_EQ_LESS_TRANS 721 \\ Q.EXISTS_TAC `LSIZE h` \\ ASM_SIMP_TAC std_ss [] 722 \\ METIS_TAC [LSIZE_CAR_LESS_EQ,LESS_EQ_TRANS]) 723 \\ ASM_SIMP_TAC std_ss [SAFE_CAR_def,SAFE_CDR_def] 724 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF,list2sexp_def] 725 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF,list2sexp_def] 726 \\ SIMP_TAC std_ss [GSYM list2sexp_def] \\ ASM_SIMP_TAC std_ss [] 727 \\ ASM_SIMP_TAC std_ss [list2sexp_def,APPEND,SFIX_sfix]) 728 \\ Cases_on `CAR x2 = Sym "LET"` \\ ASM_SIMP_TAC std_ss [] THEN1 729 (Q.PAT_X_ASSUM `LSIZE (CAR (CDR x2)) < LSIZE x2` ASSUME_TAC 730 \\ FULL_SIMP_TAC std_ss [GSYM list2sexp_def,APPEND_NIL]) 731 \\ Cases_on `CAR x2 = Sym "LET*"` \\ ASM_SIMP_TAC std_ss [] THEN1 732 (Q.PAT_X_ASSUM `LSIZE (CAR (CDR x2)) < LSIZE x2` ASSUME_TAC 733 \\ FULL_SIMP_TAC std_ss [GSYM list2sexp_def,APPEND_NIL]) 734 THEN1 735 (Q.PAT_X_ASSUM `!x.bbb` (K ALL_TAC) 736 \\ Q.PAT_X_ASSUM `!x.bbb` (MP_TAC o Q.SPECL [`x1`,`CDR x2`,`xs`,`SFIX (CAR x2)`,`[]`]) 737 \\ MATCH_MP_TAC IMP_IMP \\ STRIP_TAC 738 THEN1 (Cases_on `x2` \\ EVAL_TAC \\ FULL_SIMP_TAC std_ss [isVal_def,isSym_def] \\ DECIDE_TAC) 739 \\ REPEAT STRIP_TAC \\ FULL_SIMP_TAC std_ss [list2sexp_def] 740 \\ SIMP_TAC std_ss [SFIX_sfix,list2sexp_def,APPEND_NIL])); 741 742val mc_sexp2sexp_thm = prove( 743 ``mc_sexp2sexp_pre (x0,x1,x2,xs) /\ 744 (mc_sexp2sexp (x0,x1,x2,xs) = (x0,x1,sexp2sexp x2,xs))``, 745 SIMP_TAC std_ss [mc_sexp2sexp_def,mc_sexp2sexp_pre_def, 746 LET_DEF,mc_sexp2sexp_loop_lemma] 747 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF] 748 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF] 749 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF] 750 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_pre_alt,LET_DEF] 751 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF] 752 \\ SIMP_TAC (srw_ss()) [Once mc_sexp2sexp_loop_alt,LET_DEF]); 753 754 755(* btree implementation -- allows fast lookup and adding elements *) 756 757val SPLIT_LIST_def = Define ` 758 (SPLIT_LIST [] = ([],[])) /\ 759 (SPLIT_LIST [x] = ([x],[])) /\ 760 (SPLIT_LIST (x1::x2::xs) = 761 (x1::FST (SPLIT_LIST xs),x2::SND (SPLIT_LIST xs)))`; 762 763val LENGTH_SPLIT_LIST = prove( 764 ``!xs. (LENGTH (FST (SPLIT_LIST xs)) <= LENGTH xs) /\ 765 (LENGTH (SND (SPLIT_LIST xs)) <= LENGTH xs)``, 766 HO_MATCH_MP_TAC (fetch "-" "SPLIT_LIST_ind") 767 \\ SIMP_TAC std_ss [SPLIT_LIST_def,LENGTH] \\ DECIDE_TAC); 768 769val list2btree_def = tDefine "list2tree" ` 770 (list2btree [] = Sym "NIL") /\ 771 (list2btree (x::xs) = 772 Dot x (if xs = [] then Sym "NIL" else 773 Dot (list2btree (FST (SPLIT_LIST xs))) 774 (list2btree (SND (SPLIT_LIST xs)))))` 775 (WF_REL_TAC `measure (LENGTH)` \\ FULL_SIMP_TAC std_ss [LENGTH] 776 \\ METIS_TAC [DECIDE ``n < SUC n``,LENGTH_SPLIT_LIST,LESS_EQ_LESS_TRANS]); 777 778val btree_lookup_def = Define ` 779 btree_lookup n x = 780 if n < 2 then CAR x else 781 if EVEN n then btree_lookup (n DIV 2) (CAR (CDR x)) 782 else btree_lookup (n DIV 2) (CDR (CDR x))`; 783 784val btree_insert_def = Define ` 785 btree_insert n y x = 786 if n < 2 then Dot y (Sym "NIL") else 787 if EVEN n then 788 Dot (CAR x) (Dot (btree_insert (n DIV 2) y (CAR (CDR x))) (CDR (CDR x))) 789 else 790 Dot (CAR x) (Dot (CAR (CDR x)) (btree_insert (n DIV 2) y (CDR (CDR x))))`; 791 792(* 793 1 794 10 11 795 100 101 110 111 796 1000 1001 1010 1011 1100 1101 1110 1111 797*) 798 799val EL_SPLIT_LIST = prove( 800 ``!xs n. 801 n < LENGTH xs ==> 802 (EL n xs = if EVEN n then EL (n DIV 2) (FST (SPLIT_LIST xs)) 803 else EL (n DIV 2) (SND (SPLIT_LIST xs)))``, 804 HO_MATCH_MP_TAC (fetch "-" "SPLIT_LIST_ind") 805 \\ SIMP_TAC std_ss [SPLIT_LIST_def,LENGTH] \\ REPEAT STRIP_TAC 806 THEN1 (Cases_on `n` \\ FULL_SIMP_TAC std_ss [EL,HD] \\ `F` by DECIDE_TAC) 807 \\ Cases_on `n` \\ SIMP_TAC std_ss [EL,HD] 808 \\ Cases_on `n'` \\ SIMP_TAC std_ss [EL,HD,TL,EVEN] 809 \\ FULL_SIMP_TAC std_ss [ADD1,GSYM ADD_ASSOC] 810 \\ SIMP_TAC std_ss [(SIMP_RULE std_ss [] (Q.SPEC `2` ADD_DIV_ADD_DIV)) 811 |> RW1 [ADD_COMM] |> Q.SPEC `1` |> SIMP_RULE std_ss []] 812 \\ SIMP_TAC std_ss [GSYM ADD1,EL,TL]); 813 814val LENGTH_SPLIT_LIST = prove( 815 ``!xs. (LENGTH (SND (SPLIT_LIST xs)) = LENGTH xs DIV 2) /\ 816 (LENGTH (FST (SPLIT_LIST xs)) = LENGTH xs DIV 2 + LENGTH xs MOD 2)``, 817 HO_MATCH_MP_TAC (fetch "-" "SPLIT_LIST_ind") 818 \\ SIMP_TAC std_ss [SPLIT_LIST_def,LENGTH] 819 \\ FULL_SIMP_TAC std_ss [ADD1,GSYM ADD_ASSOC] 820 \\ SIMP_TAC std_ss [(SIMP_RULE std_ss [] (Q.SPEC `2` ADD_DIV_ADD_DIV)) 821 |> RW1 [ADD_COMM] |> Q.SPEC `1` |> SIMP_RULE std_ss []] 822 \\ SIMP_TAC std_ss [(SIMP_RULE std_ss [] (Q.SPEC `2` MOD_TIMES)) 823 |> RW1 [ADD_COMM] |> Q.SPEC `1` |> SIMP_RULE std_ss []] 824 \\ ASM_SIMP_TAC std_ss [AC ADD_ASSOC ADD_COMM]); 825 826val NOT_EVEN_LESS = prove( 827 ``~EVEN n /\ n < m ==> n < m DIV 2 * 2``, 828 Cases_on `EVEN m` 829 \\ IMP_RES_TAC EVEN_ODD_EXISTS 830 \\ FULL_SIMP_TAC std_ss [RW1 [MULT_COMM] MULT_DIV] 831 \\ SIMP_TAC std_ss [Once MULT_COMM] 832 \\ FULL_SIMP_TAC std_ss [GSYM ODD_EVEN] 833 \\ REPEAT STRIP_TAC 834 \\ IMP_RES_TAC EVEN_ODD_EXISTS 835 \\ FULL_SIMP_TAC std_ss [ADD1,RW1[MULT_COMM]DIV_MULT] 836 \\ DECIDE_TAC); 837 838val DIV_LESS_LENGTH_SPLIT_LIST = prove( 839 ``n < LENGTH (t:SExp list) ==> 840 if EVEN n then n DIV 2 < LENGTH (FST (SPLIT_LIST t)) 841 else n DIV 2 < LENGTH (SND (SPLIT_LIST t))``, 842 Cases_on `EVEN n` \\ ASM_SIMP_TAC std_ss [] THEN1 843 (FULL_SIMP_TAC std_ss [LENGTH_SPLIT_LIST] 844 \\ SIMP_TAC std_ss [DIV_LT_X,RIGHT_ADD_DISTRIB] \\ STRIP_TAC 845 \\ ASSUME_TAC (Q.SPEC `LENGTH (t:SExp list)` (MATCH_MP DIVISION (DECIDE ``0<2``))) 846 \\ DECIDE_TAC) THEN1 847 (FULL_SIMP_TAC std_ss [LENGTH_SPLIT_LIST] 848 \\ SIMP_TAC std_ss [DIV_LT_X,RIGHT_ADD_DISTRIB] 849 \\ METIS_TAC [NOT_EVEN_LESS])); 850 851val btree_lookup_thm = prove( 852 ``!n xs. 853 n < LENGTH xs ==> 854 (btree_lookup (n+1) (list2btree xs) = EL n xs)``, 855 completeInduct_on `n` \\ REPEAT STRIP_TAC 856 \\ Cases_on `n = 0` \\ ASM_SIMP_TAC std_ss [Once btree_lookup_def] THEN1 857 (Cases_on `xs` \\ FULL_SIMP_TAC std_ss [LENGTH] 858 \\ SIMP_TAC std_ss [list2btree_def,CAR_def,EL,HD]) 859 \\ `~(n + 1 < 2)` by DECIDE_TAC \\ ASM_SIMP_TAC std_ss [] 860 \\ SIMP_TAC std_ss [EVEN,GSYM ADD1] 861 \\ Cases_on `n` \\ FULL_SIMP_TAC std_ss [EVEN] 862 \\ SIMP_TAC std_ss [ADD1,GSYM ADD_ASSOC] 863 \\ SIMP_TAC std_ss [(SIMP_RULE std_ss [] (Q.SPEC `2` ADD_DIV_ADD_DIV)) 864 |> RW1 [ADD_COMM] |> Q.SPEC `1` |> SIMP_RULE std_ss []] 865 \\ SIMP_TAC std_ss [RW[ADD1]EL] 866 \\ Cases_on `xs` \\ FULL_SIMP_TAC std_ss [LENGTH,TL] 867 \\ SIMP_TAC std_ss [list2btree_def,CAR_def,EL,HD,CDR_def] 868 \\ Cases_on `t = []` \\ FULL_SIMP_TAC std_ss [LENGTH,CDR_def,CAR_def] 869 \\ `n' DIV 2 < SUC n'` by (ASM_SIMP_TAC std_ss [DIV_LT_X] \\ DECIDE_TAC) 870 \\ IMP_RES_TAC DIV_LESS_LENGTH_SPLIT_LIST 871 \\ Cases_on `EVEN n'` \\ FULL_SIMP_TAC std_ss [] 872 \\ RES_TAC \\ ASM_SIMP_TAC std_ss [EL_SPLIT_LIST]); 873 874val SPLIT_LIST_SNOC = prove( 875 ``!xs x. 876 (FST (SPLIT_LIST (xs ++ [x])) = 877 if EVEN (LENGTH xs) then FST (SPLIT_LIST xs) ++ [x] 878 else FST (SPLIT_LIST xs)) /\ 879 (SND (SPLIT_LIST (xs ++ [x])) = 880 if EVEN (LENGTH xs) then SND (SPLIT_LIST xs) 881 else SND (SPLIT_LIST xs) ++ [x])``, 882 STRIP_TAC \\ completeInduct_on `LENGTH xs` \\ NTAC 3 STRIP_TAC 883 \\ FULL_SIMP_TAC std_ss [PULL_FORALL_IMP] 884 \\ Cases_on `xs` THEN1 (EVAL_TAC \\ SIMP_TAC std_ss []) 885 \\ Cases_on `t` THEN1 (EVAL_TAC \\ SIMP_TAC std_ss []) 886 \\ FULL_SIMP_TAC std_ss [LENGTH,EVEN,SPLIT_LIST_def,APPEND] 887 \\ `LENGTH t' < SUC (SUC (LENGTH t'))` by DECIDE_TAC 888 \\ ASM_SIMP_TAC std_ss [] \\ METIS_TAC []); 889 890val LENGTH_SPLIT_LIST_LESS_SUC_LENGTH = prove( 891 ``LENGTH (FST (SPLIT_LIST t)) < SUC (LENGTH t) /\ 892 LENGTH (SND (SPLIT_LIST t)) < SUC (LENGTH (t:SExp list))``, 893 SIMP_TAC std_ss [LENGTH_SPLIT_LIST] \\ Q.SPEC_TAC (`LENGTH t`,`n`) 894 \\ SIMP_TAC std_ss [DIV_LT_X] \\ REVERSE (REPEAT STRIP_TAC) THEN1 DECIDE_TAC 895 \\ MATCH_MP_TAC LESS_EQ_LESS_TRANS \\ Q.EXISTS_TAC `2 * (n DIV 2) + n MOD 2` 896 \\ REPEAT STRIP_TAC THEN1 (SIMP_TAC std_ss [TIMES2] \\ DECIDE_TAC) 897 \\ ONCE_REWRITE_TAC [MULT_COMM] 898 \\ SIMP_TAC std_ss [GSYM (MATCH_MP DIVISION (DECIDE ``0<2:num``))]); 899 900val btree_insert_thm = prove( 901 ``!xs y. btree_insert (LENGTH xs + 1) y (list2btree xs) = list2btree (xs ++ [y])``, 902 STRIP_TAC \\ completeInduct_on `LENGTH xs` \\ REPEAT STRIP_TAC 903 \\ Cases_on `xs` THEN1 904 (SIMP_TAC std_ss [LENGTH,list2btree_def,APPEND,SPLIT_LIST_def] 905 \\ SIMP_TAC std_ss [Once btree_insert_def]) 906 \\ SIMP_TAC std_ss [list2btree_def,APPEND] 907 \\ Cases_on `t = []` \\ FULL_SIMP_TAC std_ss [] 908 THEN1 (FULL_SIMP_TAC std_ss [LENGTH,APPEND,NOT_CONS_NIL] \\ EVAL_TAC) 909 \\ SIMP_TAC std_ss [APPEND_eq_NIL,NOT_CONS_NIL] 910 \\ SIMP_TAC std_ss [Once btree_insert_def,CAR_def,CDR_def,LENGTH] 911 \\ `~(SUC (LENGTH t) + 1 < 2)` by DECIDE_TAC \\ ASM_SIMP_TAC std_ss [] 912 \\ SIMP_TAC std_ss [GSYM ADD1,EVEN] 913 \\ SIMP_TAC std_ss [ADD1,GSYM ADD_ASSOC] 914 \\ SIMP_TAC std_ss [(SIMP_RULE std_ss [] (Q.SPEC `2` ADD_DIV_ADD_DIV)) 915 |> RW1 [ADD_COMM] |> Q.SPEC `1` |> SIMP_RULE std_ss []] 916 \\ FULL_SIMP_TAC std_ss [LENGTH,PULL_FORALL_IMP] 917 \\ STRIP_ASSUME_TAC LENGTH_SPLIT_LIST_LESS_SUC_LENGTH 918 \\ RES_TAC \\ ASM_SIMP_TAC std_ss [] 919 \\ FULL_SIMP_TAC std_ss [LENGTH_SPLIT_LIST] 920 \\ REVERSE (Cases_on `EVEN (LENGTH t)`) 921 \\ ASM_SIMP_TAC std_ss [SPLIT_LIST_SNOC] 922 \\ FULL_SIMP_TAC std_ss [EVEN_MOD2]); 923 924 925(* tail-recursive version of insert *) 926 927val btree_insert_pushes_def = Define ` 928 btree_insert_pushes n x = 929 if n < 2 then [] else 930 if EVEN n then 931 btree_insert_pushes (n DIV 2) (CAR (CDR x)) ++ [Val 0;x] 932 else 933 btree_insert_pushes (n DIV 2) (CDR (CDR x)) ++ [Val 1;x]`; 934 935val btree_insert_pushes_tr_def = Define ` 936 btree_insert_pushes_tr n x xs = 937 if n < 2 then xs else 938 if EVEN n then 939 btree_insert_pushes_tr (n DIV 2) (CAR (CDR x)) ([Val 0;x] ++ xs) 940 else 941 btree_insert_pushes_tr (n DIV 2) (CDR (CDR x)) ([Val 1;x] ++ xs)`; 942 943val (_,mc_btree_insert_pushes_def,mc_btree_insert_pushes_pre_def) = compile "x64" `` 944 mc_btree_insert_pushes (x0,x1,x2,xs) = 945 if x0 = Val 0 then (x0,x1,x2,xs) else 946 if x0 = Val 1 then (x0,x1,x2,xs) else 947 if EVEN (getVal x0) then 948 let x2 = Val 0 in 949 let xs = x1::xs in 950 let xs = x2::xs in 951 let x0 = Val (getVal x0 DIV 2) in 952 let x1 = SAFE_CDR x1 in 953 let x1 = SAFE_CAR x1 in 954 mc_btree_insert_pushes (x0,x1,x2,xs) 955 else 956 let x2 = Val 1 in 957 let xs = x1::xs in 958 let xs = x2::xs in 959 let x0 = Val (getVal x0 DIV 2) in 960 let x1 = SAFE_CDR x1 in 961 let x1 = SAFE_CDR x1 in 962 mc_btree_insert_pushes (x0,x1,x2,xs)``; 963 964val btree_insert_pops_def = Define ` 965 (btree_insert_pops y [] = y) /\ 966 (btree_insert_pops y [x] = y) /\ 967 (btree_insert_pops y (x::x2::xs) = 968 if x = Val 0 then 969 btree_insert_pops (Dot (CAR x2) (Dot y (CDR (CDR x2)))) xs 970 else 971 btree_insert_pops (Dot (CAR x2) (Dot (CAR (CDR x2)) y)) xs)` 972 973val (_,mc_btree_insert_pops_def,mc_btree_insert_pops_pre_def) = compile "x64" `` 974 mc_btree_insert_pops (x0,x1,xs) = 975 let x0 = HD xs in 976 let xs = TL xs in 977 if ~(isVal x0) then (x0,x1,xs) else 978 if x0 = Val 0 then 979 let x0 = HD xs in 980 let x0 = SAFE_CDR x0 in 981 let x0 = SAFE_CDR x0 in 982 let x1 = Dot x1 x0 in 983 let x0 = HD xs in 984 let xs = TL xs in 985 let x0 = SAFE_CAR x0 in 986 let x0 = Dot x0 x1 in 987 let x1 = x0 in 988 mc_btree_insert_pops (x0,x1,xs) 989 else 990 let x0 = HD xs in 991 let x0 = SAFE_CDR x0 in 992 let x0 = SAFE_CAR x0 in 993 let x0 = Dot x0 x1 in 994 let x1 = x0 in 995 let x0 = HD xs in 996 let xs = TL xs in 997 let x0 = SAFE_CAR x0 in 998 let x0 = Dot x0 x1 in 999 let x1 = x0 in 1000 mc_btree_insert_pops (x0,x1,xs)`` 1001 1002val btree_insert_tr_def = Define ` 1003 btree_insert_tr n y x = 1004 btree_insert_pops (Dot y (Sym "NIL")) (btree_insert_pushes_tr n x [])`; 1005 1006val btree_insert_pops_thm = prove( 1007 ``!n x y z xs. 1008 btree_insert_pops (btree_insert 0 y z) (btree_insert_pushes n x ++ xs) = 1009 btree_insert_pops (btree_insert n y x) xs``, 1010 STRIP_TAC \\ completeInduct_on `n` \\ REPEAT STRIP_TAC 1011 \\ Cases_on `n = 0` \\ ASM_SIMP_TAC std_ss [] 1012 \\ SIMP_TAC std_ss [Once btree_insert_pushes_def,APPEND] 1013 THEN1 (SIMP_TAC std_ss [Once btree_insert_def] 1014 \\ SIMP_TAC std_ss [Once btree_insert_def]) 1015 \\ Cases_on `n < 2` \\ ASM_SIMP_TAC std_ss [] 1016 THEN1 (ASM_SIMP_TAC std_ss [Once btree_insert_pushes_def,APPEND] 1017 \\ SIMP_TAC std_ss [Once btree_insert_def] 1018 \\ ASM_SIMP_TAC std_ss [Once btree_insert_def]) 1019 \\ `n DIV 2 < n` by (SIMP_TAC std_ss [DIV_LT_X] \\ DECIDE_TAC) 1020 \\ RES_TAC \\ Cases_on `EVEN n` \\ ASM_SIMP_TAC std_ss [] 1021 \\ ASM_SIMP_TAC std_ss [GSYM APPEND_ASSOC,APPEND] 1022 \\ ASM_SIMP_TAC std_ss [btree_insert_pops_def] 1023 \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] 1024 \\ ASM_SIMP_TAC (srw_ss()) [Once btree_insert_def]); 1025 1026val EVEN_LENGTH_INDUCT = prove( 1027 ``!P. (P []) /\ (!y1 y2 ys. P ys ==> P (y1::y2::ys)) ==> 1028 !ys. EVEN (LENGTH ys) ==> P ys``, 1029 REPEAT STRIP_TAC \\ completeInduct_on `LENGTH ys` 1030 \\ Cases \\ ASM_SIMP_TAC std_ss [] 1031 \\ Cases_on `t` \\ FULL_SIMP_TAC std_ss [EVEN,LENGTH] 1032 \\ FULL_SIMP_TAC std_ss [ADD1,GSYM ADD_ASSOC]); 1033 1034val EVERY_OTHER_VAL_def = Define ` 1035 (EVERY_OTHER_VAL [] = T) /\ 1036 (EVERY_OTHER_VAL [x] = T) /\ 1037 (EVERY_OTHER_VAL (x::y::xs) = isVal x /\ EVERY_OTHER_VAL xs)`; 1038 1039val mc_btree_insert_pops_thm = prove( 1040 ``!ys. EVEN (LENGTH ys) ==> !x0 y xs. 1041 EVERY_OTHER_VAL ys ==> 1042 ?y0. mc_btree_insert_pops_pre (x0,y,ys ++ Sym "NIL"::xs) /\ 1043 (mc_btree_insert_pops (x0,y,ys ++ Sym "NIL"::xs) = 1044 (y0,btree_insert_pops y ys,xs))``, 1045 HO_MATCH_MP_TAC EVEN_LENGTH_INDUCT \\ REPEAT STRIP_TAC 1046 \\ SIMP_TAC std_ss [btree_insert_pops_def,APPEND] 1047 \\ ONCE_REWRITE_TAC [mc_btree_insert_pops_def,mc_btree_insert_pops_pre_def] 1048 \\ SIMP_TAC std_ss [HD,TL,LET_DEF,isVal_def,SAFE_CAR_def,SAFE_CDR_def] 1049 \\ FULL_SIMP_TAC std_ss [EVERY_OTHER_VAL_def,NOT_CONS_NIL] 1050 \\ METIS_TAC []); 1051 1052val mc_btree_insert_pushes_thm = prove( 1053 ``!n x1 x2 xs. 1054 ?y0 y1 y2. 1055 mc_btree_insert_pushes_pre (Val n,x1,x2,xs) /\ 1056 (mc_btree_insert_pushes (Val n,x1,x2,xs) = 1057 (y0,y1,y2,btree_insert_pushes n x1 ++ xs))``, 1058 STRIP_TAC \\ completeInduct_on `n` \\ REPEAT STRIP_TAC 1059 \\ Cases_on `n < 2` \\ ASM_SIMP_TAC std_ss [] 1060 \\ ASM_SIMP_TAC std_ss [Once btree_insert_pushes_def,SAFE_CAR_def,SAFE_CDR_def, 1061 Once mc_btree_insert_pushes_def,Once mc_btree_insert_pushes_pre_def,APPEND] 1062 THEN1 (SRW_TAC [] [] \\ `F` by DECIDE_TAC) 1063 \\ `~(n = 0) /\ ~(n = 1)` by DECIDE_TAC 1064 \\ FULL_SIMP_TAC std_ss [SExp_11,getVal_def,LET_DEF] 1065 \\ `n DIV 2 < n` by (SIMP_TAC std_ss [DIV_LT_X] \\ DECIDE_TAC) 1066 \\ RES_TAC \\ POP_ASSUM (fn th => 1067 (STRIP_ASSUME_TAC o Q.SPECL [`Val 1::x1::xs`,`Val 1`,`CDR (CDR x1)`]) th THEN 1068 (STRIP_ASSUME_TAC o Q.SPECL [`Val 0::x1::xs`,`Val 0`,`CAR (CDR x1)`]) th) 1069 \\ ASM_SIMP_TAC std_ss [] \\ Cases_on `EVEN n` \\ ASM_SIMP_TAC std_ss [] 1070 \\ ASM_SIMP_TAC std_ss [GSYM APPEND_ASSOC,APPEND,isVal_def]); 1071 1072val btree_insert_pushes_tr_thm = prove( 1073 ``!n x xs. btree_insert_pushes_tr n x xs = btree_insert_pushes n x ++ xs``, 1074 STRIP_TAC \\ completeInduct_on `n` \\ REPEAT STRIP_TAC 1075 \\ Cases_on `n < 2` \\ ASM_SIMP_TAC std_ss [] 1076 \\ ASM_SIMP_TAC std_ss [Once btree_insert_pushes_def, 1077 Once btree_insert_pushes_tr_def,APPEND] 1078 \\ `n DIV 2 < n` by (SIMP_TAC std_ss [DIV_LT_X] \\ DECIDE_TAC) 1079 \\ RES_TAC \\ Cases_on `EVEN n` \\ ASM_SIMP_TAC std_ss [] 1080 \\ ASM_SIMP_TAC std_ss [GSYM APPEND_ASSOC,APPEND]); 1081 1082val btree_insert_tr_thm = prove( 1083 ``!n y x. btree_insert_tr n y x = btree_insert n y x``, 1084 SIMP_TAC std_ss [btree_insert_tr_def,btree_insert_pushes_tr_thm] 1085 \\ REPEAT STRIP_TAC \\ `Dot y (Sym "NIL") = btree_insert 0 y x` by EVAL_TAC 1086 \\ ASM_SIMP_TAC std_ss [btree_insert_pops_thm] 1087 \\ SIMP_TAC std_ss [Once btree_insert_pops_def]); 1088 1089val (_,mc_btree_insert_def,mc_btree_insert_pre_def) = compile "x64" `` 1090 mc_btree_insert (x0,x1,x2,x3,xs) = 1091 let xs = x0::xs in 1092 let xs = x1::xs in 1093 let xs = x2::xs in 1094 let x2 = Sym "NIL" in 1095 let x3 = Dot x3 x2 in 1096 let xs = x2::xs in 1097 let (x0,x1,x2,xs) = mc_btree_insert_pushes (x0,x1,x2,xs) in 1098 let x1 = x3 in 1099 let (x0,x1,xs) = mc_btree_insert_pops (x0,x1,xs) in 1100 let x3 = x1 in 1101 let x2 = HD xs in 1102 let xs = TL xs in 1103 let x1 = HD xs in 1104 let xs = TL xs in 1105 let x0 = HD xs in 1106 let xs = TL xs in 1107 (x0,x1,x2,x3,xs)`` 1108 1109val EVEN_ADD2 = prove( 1110 ``EVEN (n + 2) = EVEN n``, 1111 SIMP_TAC std_ss [DECIDE ``n+2 = SUC (SUC n)``,EVEN]); 1112 1113val btree_insert_pushes_lemma_step = prove( 1114 ``!ys. EVEN (LENGTH ys) ==> 1115 (EVERY_OTHER_VAL (ys ++ zs) = EVERY_OTHER_VAL ys /\ EVERY_OTHER_VAL zs)``, 1116 HO_MATCH_MP_TAC EVEN_LENGTH_INDUCT \\ REPEAT STRIP_TAC 1117 \\ ASM_SIMP_TAC std_ss [EVERY_OTHER_VAL_def,APPEND,CONJ_ASSOC]); 1118 1119val btree_insert_pushes_lemma = prove( 1120 ``!n y. EVEN (LENGTH (btree_insert_pushes n y)) /\ 1121 EVERY_OTHER_VAL (btree_insert_pushes n y)``, 1122 completeInduct_on `n` \\ ONCE_REWRITE_TAC [btree_insert_pushes_def] 1123 \\ SRW_TAC [] [EVERY_OTHER_VAL_def,EVEN,LENGTH] 1124 \\ `n DIV 2 < n` by (SIMP_TAC std_ss [DIV_LT_X] \\ DECIDE_TAC) 1125 \\ RES_TAC \\ FULL_SIMP_TAC std_ss [EVEN_ADD2, 1126 btree_insert_pushes_lemma_step] \\ EVAL_TAC); 1127 1128val mc_btree_insert_thm = prove( 1129 ``!n x1 x2 xs. 1130 mc_btree_insert_pre (Val n,y,x2,x,xs) /\ 1131 (mc_btree_insert (Val n,y,x2,x,xs) = 1132 (Val n,y,x2,btree_insert n x y,xs))``, 1133 SIMP_TAC std_ss [] 1134 \\ ONCE_REWRITE_TAC [mc_btree_insert_def,mc_btree_insert_pre_def] 1135 \\ FULL_SIMP_TAC std_ss [LET_DEF] \\ REPEAT STRIP_TAC 1136 \\ STRIP_ASSUME_TAC (Q.SPECL [`n`,`y`,`Sym "NIL"`,`Sym "NIL"::x2::y::Val n::xs`] mc_btree_insert_pushes_thm) 1137 \\ FULL_SIMP_TAC std_ss [] 1138 \\ STRIP_ASSUME_TAC (Q.SPECL [`btree_insert_pushes n y`,`y0`,`Dot x (Sym "NIL")`,`x2::y::Val n::xs`] 1139 (SIMP_RULE std_ss [PULL_FORALL_IMP] mc_btree_insert_pops_thm)) 1140 \\ FULL_SIMP_TAC std_ss [HD,TL,btree_insert_pushes_lemma] 1141 \\ FULL_SIMP_TAC std_ss [GSYM btree_insert_tr_thm] 1142 \\ FULL_SIMP_TAC std_ss [btree_insert_tr_def,btree_insert_pushes_tr_thm] 1143 \\ FULL_SIMP_TAC std_ss [APPEND_NIL,NOT_CONS_NIL]); 1144 1145 1146(* tail-recursive version of BC_ev *) 1147 1148(* these constants are chosen at random: they must all be distinct *) 1149val COMPILE_EV = ``Val 0`` 1150val COMPILE_EVL = ``Val 1`` 1151val COMPILE_AP = ``Val 2`` 1152val CONTINUE = ``Sym "NIL"`` 1153val COMPILE_LAM1 = ``Val 3`` 1154val COMPILE_LAM2 = ``Val 4`` 1155val COMPILE_IF2 = ``Val 5`` 1156val COMPILE_IF3 = ``Val 6`` 1157val COMPILE_SET_RET = ``Val 7`` 1158val COMPILE_CALL = ``Val 8`` 1159val COMPILE_TAILOPT = ``Val 9`` 1160val COMPILE_MACRO = ``Val 10`` 1161val COMPILE_OR2 = ``Val 11`` 1162 1163(* variable assignments: 1164 x0 -- temp 1165 x1 -- task 1166 x2 -- term(s) to be compiled 1167 x3 -- a2sexp a 1168 x4 -- boo2sexp ret 1169 x5 -- bc_state 1170*) 1171 1172val bool2sexp_def = Define ` 1173 (bool2sexp T = Sym "T") /\ 1174 (bool2sexp F = Sym "NIL")`; 1175 1176val code_ptr_REPLACE_CODE = prove( 1177 ``code_ptr (REPLACE_CODE code x y) = code_ptr code``, 1178 Cases_on `code` \\ Cases_on `p` 1179 \\ ASM_SIMP_TAC std_ss [REPLACE_CODE_def,code_ptr_def]); 1180 1181val code_length_APPEND = prove( 1182 ``!xs ys. code_length (xs ++ ys) = code_length xs + code_length ys``, 1183 Induct \\ ASM_SIMP_TAC std_ss [code_length_def,APPEND,ADD_ASSOC]); 1184 1185val SND_WRITE_CODE = prove( 1186 ``!xs code. code_ptr (WRITE_CODE code xs) = code_ptr code + code_length xs``, 1187 Induct \\ Cases_on `code` \\ Cases_on `p` 1188 \\ FULL_SIMP_TAC std_ss [WRITE_CODE_def,code_length_def,ADD_ASSOC,code_ptr_def]); 1189 1190val WRITE_CODE_NIL = prove( 1191 ``!code. WRITE_CODE code [] = code``, 1192 Cases \\ Cases_on `p` \\ SIMP_TAC std_ss [WRITE_CODE_def]); 1193 1194val REPLACE_CODE_WRITE_CODE = prove( 1195 ``!xs code n y. 1196 n < code_ptr code ==> 1197 (REPLACE_CODE (WRITE_CODE code xs) n y = 1198 WRITE_CODE (REPLACE_CODE code n y) xs)``, 1199 Induct \\ SIMP_TAC std_ss [code_length_def,WRITE_CODE_NIL] 1200 \\ REPEAT STRIP_TAC \\ Cases_on `code` \\ Cases_on `p` 1201 \\ FULL_SIMP_TAC std_ss [WRITE_CODE_def,code_ptr_def] 1202 \\ Q.PAT_X_ASSUM `!code. bbb` (MP_TAC o Q.SPECL 1203 [`BC_CODE ((r =+ SOME h) q,r + bc_length h)`,`n`,`y`]) 1204 \\ FULL_SIMP_TAC std_ss [code_ptr_def,AC ADD_COMM ADD_ASSOC] 1205 \\ `n < r + bc_length h` by DECIDE_TAC \\ FULL_SIMP_TAC std_ss [] 1206 \\ REPEAT STRIP_TAC \\ FULL_SIMP_TAC std_ss [WRITE_CODE_def,REPLACE_CODE_def] 1207 \\ `~(r = n)` by DECIDE_TAC \\ METIS_TAC [UPDATE_COMMUTES]); 1208 1209val code_ptr_WRITE_CODE_lemma = prove( 1210 ``!code x. code_ptr (WRITE_CODE code [x]) = code_ptr code + bc_length x``, 1211 Cases \\ Cases \\ Cases_on `p` \\ SIMP_TAC std_ss [WRITE_CODE_def,code_ptr_def]); 1212 1213val code_ptr_WRITE_CODE = prove( 1214 ``!xs code. code_ptr (WRITE_CODE code xs) = code_ptr code + code_length xs``, 1215 Induct \\ SIMP_TAC std_ss [WRITE_CODE_NIL,code_length_def] 1216 \\ REPEAT STRIP_TAC \\ Cases_on `code` \\ Cases_on `p` 1217 \\ FULL_SIMP_TAC std_ss [WRITE_CODE_def,code_ptr_def] 1218 \\ FULL_SIMP_TAC std_ss [AC ADD_COMM ADD_ASSOC]); 1219 1220val WRITE_CODE_APPEND = prove( 1221 ``!xs ys s. WRITE_CODE (WRITE_CODE s xs) ys = WRITE_CODE s (xs ++ ys)``, 1222 Induct \\ Cases_on `s` \\ Cases_on `p` 1223 \\ FULL_SIMP_TAC std_ss [FORALL_PROD,WRITE_CODE_def,APPEND]); 1224 1225val REPLACE_CODE_RW = prove( 1226 ``(bc_length x = bc_length y) ==> 1227 (REPLACE_CODE (WRITE_CODE code (x_code ++ ([x] ++ y_code))) 1228 (code_ptr code + code_length x_code) y = 1229 WRITE_CODE code (x_code ++ ([y] ++ y_code)))``, 1230 SIMP_TAC std_ss [GSYM WRITE_CODE_APPEND] 1231 \\ MP_TAC (Q.SPECL [`y_code`,`WRITE_CODE (WRITE_CODE code x_code) [x]`,`code_ptr code + code_length x_code`,`y`] REPLACE_CODE_WRITE_CODE) 1232 \\ FULL_SIMP_TAC std_ss [code_ptr_WRITE_CODE] 1233 \\ `0 < code_length [x]` by 1234 (Cases_on `x` \\ EVAL_TAC \\ Cases_on `l` \\ EVAL_TAC) 1235 \\ FULL_SIMP_TAC std_ss [] \\ REPEAT STRIP_TAC 1236 \\ AP_THM_TAC \\ AP_TERM_TAC 1237 \\ Cases_on `WRITE_CODE code x_code` 1238 \\ Cases_on `p` \\ Cases_on `code` \\ Cases_on `p` 1239 \\ FULL_SIMP_TAC std_ss [WRITE_CODE_def,REPLACE_CODE_def,code_ptr_def] 1240 \\ sg `r' + code_length x_code = r` 1241 \\ FULL_SIMP_TAC std_ss [UPDATE_EQ] 1242 \\ `code_ptr (WRITE_CODE (BC_CODE (q',r')) x_code) = code_ptr (BC_CODE (q,r))` by METIS_TAC [] 1243 \\ FULL_SIMP_TAC std_ss [code_ptr_def,code_ptr_WRITE_CODE]); 1244 1245val code_mem_WRITE_CODE_LESS = store_thm("code_mem_WRITE_CODE_LESS", 1246 ``!xs code i. 1247 i < code_ptr code ==> 1248 (code_mem (WRITE_CODE code xs) i = code_mem code i)``, 1249 Induct 1250 THEN1 (Cases_on `code` \\ Cases_on `p` \\ SIMP_TAC std_ss [WRITE_CODE_def]) 1251 \\ ONCE_REWRITE_TAC [GSYM (EVAL ``[x] ++ ys``)] 1252 \\ SIMP_TAC std_ss [GSYM WRITE_CODE_APPEND] 1253 \\ REPEAT STRIP_TAC 1254 \\ `i < code_ptr (WRITE_CODE code [h])` by 1255 (Cases_on `code` \\ Cases_on `p` 1256 \\ FULL_SIMP_TAC std_ss [WRITE_CODE_def,code_ptr_def] \\ DECIDE_TAC) 1257 \\ RES_TAC \\ ASM_SIMP_TAC std_ss [] 1258 \\ Cases_on `code` \\ Cases_on `p` 1259 \\ FULL_SIMP_TAC std_ss [WRITE_CODE_def,code_mem_def,APPLY_UPDATE_THM,code_ptr_def] 1260 \\ `~(i = r)` by DECIDE_TAC \\ ASM_SIMP_TAC std_ss []); 1261 1262val code_mem_WRITE_CODE = prove( 1263 ``!xs y ys code. 1264 (code_mem (WRITE_CODE code (xs ++ y::ys)) (code_length xs + code_ptr code) = SOME y)``, 1265 Induct \\ REPEAT STRIP_TAC THEN1 1266 (SIMP_TAC std_ss [APPEND,code_length_def] 1267 \\ ONCE_REWRITE_TAC [GSYM (EVAL ``[x] ++ ys``)] 1268 \\ SIMP_TAC std_ss [GSYM WRITE_CODE_APPEND] 1269 \\ `code_ptr code < code_ptr (WRITE_CODE code [y])` by 1270 (Cases_on `code` \\ Cases_on `p` 1271 \\ FULL_SIMP_TAC std_ss [WRITE_CODE_def,code_ptr_def] 1272 \\ Cases_on `y` \\ EVAL_TAC \\ Cases_on `l` \\ EVAL_TAC) 1273 \\ IMP_RES_TAC code_mem_WRITE_CODE_LESS 1274 \\ ASM_SIMP_TAC std_ss [] 1275 \\ Cases_on `code` \\ Cases_on `p` 1276 \\ SIMP_TAC std_ss [WRITE_CODE_def,code_mem_def,code_ptr_def,APPLY_UPDATE_THM]) 1277 \\ SIMP_TAC std_ss [APPEND] 1278 \\ ONCE_REWRITE_TAC [GSYM (EVAL ``[x] ++ ys``)] 1279 \\ SIMP_TAC std_ss [Once (GSYM WRITE_CODE_APPEND)] 1280 \\ `(code_length ([h] ++ xs) + code_ptr code) = 1281 (code_length xs + code_ptr (WRITE_CODE code [h]))` by 1282 (SIMP_TAC std_ss [code_ptr_WRITE_CODE,code_length_APPEND,AC ADD_COMM ADD_ASSOC]) 1283 \\ ASM_SIMP_TAC std_ss []); 1284 1285val code_mem_WRITE_CODE_IMP = prove( 1286 ``!xs y ys code l. 1287 ((code_length xs + code_ptr code) = l) ==> 1288 (code_mem (WRITE_CODE code (xs ++ y::ys)) l = SOME y)``, 1289 SIMP_TAC std_ss [code_mem_WRITE_CODE]); 1290 1291val a2sexp_aux_def = Define ` 1292 (a2sexp_aux ssTEMP = Val 0) /\ 1293 (a2sexp_aux (ssVAR v) = Sym v)`; 1294 1295val a2sexp_def = Define ` 1296 a2sexp a = list2sexp (MAP a2sexp_aux a)`; 1297 1298val bc_inv_def = Define ` 1299 bc_inv bc = (bc.instr_length = bc_length) /\ BC_CODE_OK bc`; 1300 1301val term2sexp_guard_lemma = prove( 1302 ``~isVal (term2sexp (App fc xs)) /\ 1303 ~isDot (CAR (term2sexp (App fc xs))) /\ 1304 ~isQuote (term2sexp (App fc xs)) /\ 1305 ~(CAR (term2sexp (App fc xs)) = Sym "IF") /\ 1306 ~(CAR (term2sexp (App fc xs)) = Sym "OR") /\ 1307 ~(isSym (term2sexp (App fc xs))) /\ 1308 ~(term2sexp (App fc xs) = Sym "NIL") /\ 1309 ~(term2sexp (App fc xs) = Sym "T") /\ 1310 ~(CAR (term2sexp (App fc xs)) = Val 1)``, 1311 REVERSE (Cases_on `fc`) THEN1 1312 (SIMP_TAC std_ss [term2sexp_def,func2sexp_def] 1313 \\ Cases_on `MEM s reserved_names` \\ ASM_SIMP_TAC std_ss [] 1314 \\ FULL_SIMP_TAC std_ss [MEM,reserved_names_def,macro_names_def,APPEND] 1315 \\ ASM_SIMP_TAC (srw_ss()) [APPEND,list2sexp_def,CAR_def,CDR_def] \\ EVAL_TAC 1316 \\ ASM_SIMP_TAC (srw_ss()) [APPEND,list2sexp_def,CAR_def,CDR_def] \\ EVAL_TAC) 1317 \\ REPEAT (Cases_on `l`) \\ EVAL_TAC); 1318 1319val iLENGTH_thm = prove( 1320 ``!fs bc. bc_inv bc ==> (iLENGTH bc.instr_length = code_length) /\ 1321 (iLENGTH bc_length = code_length)``, 1322 REPEAT STRIP_TAC \\ SIMP_TAC std_ss [FUN_EQ_THM] \\ Induct 1323 \\ ASM_SIMP_TAC std_ss [iLENGTH_def,code_length_def] 1324 \\ FULL_SIMP_TAC std_ss [bc_inv_def]); 1325 1326val sexp2list_list2sexp = prove( 1327 ``!xs. sexp2list (list2sexp xs) = xs``, 1328 Induct \\ ASM_SIMP_TAC std_ss [sexp2list_def,list2sexp_def]); 1329 1330val s2sexp_retract = prove( 1331 ``!a. Dot (Val 0) (a2sexp a) = a2sexp (ssTEMP::a)``, 1332 SIMP_TAC std_ss [a2sexp_def,a2sexp_aux_def,MAP,list2sexp_def]); 1333 1334val const_tree_def = Define ` 1335 const_tree bc = Dot (Val (LENGTH bc.consts)) (list2btree bc.consts)`; 1336 1337val flat_alist_def = Define ` 1338 (flat_alist [] = []) /\ 1339 (flat_alist ((x,(y,z))::xs) = Sym x::(Dot (Val y) (Val z))::flat_alist xs)`; 1340 1341val bc_state_tree_def = Define ` 1342 bc_state_tree bc = Dot (Sym "NIL") (list2sexp (flat_alist bc.compiled))`; 1343 1344val bc_inv_ADD_CONST = prove( 1345 ``(bc_inv (BC_ADD_CONST bc s) = bc_inv bc) /\ 1346 ((BC_ADD_CONST bc s).compiled = bc.compiled) /\ 1347 (bc_state_tree (BC_ADD_CONST bc s) = bc_state_tree bc)``, 1348 SIMP_TAC (srw_ss()) [bc_inv_def,BC_ADD_CONST_def,BC_CODE_OK_def,bc_state_tree_def]); 1349 1350(* 1351 1352(* add const *) 1353 1354val (_,mc_add_const_def,mc_add_const_pre_def) = compile "x64" `` 1355 mc_add_const (x2,x3,x5,xs) = 1356 let xs = x2::xs in 1357 let xs = x3::xs in 1358 let xs = x5::xs in 1359 let x5 = CAR x5 in 1360 let x0 = CAR x5 in 1361 let x0 = LISP_ADD x0 (Val 1) in 1362 let x3 = x2 in 1363 let x2 = CDR x5 in 1364 let x1 = x2 in 1365 let (x0,x1,x2,x3,xs) = mc_btree_insert (x0,x1,x2,x3,xs) in 1366 let x0 = Dot x0 x3 in 1367 let x5 = x0 in 1368 let x3 = HD xs in 1369 let xs = TL xs in 1370 let x3 = CDR x3 in 1371 let x5 = Dot x5 x3 in 1372 let x3 = HD xs in 1373 let xs = TL xs in 1374 let x2 = HD xs in 1375 let xs = TL xs in 1376 let x0 = Sym "NIL" in 1377 let x1 = Sym "NIL" in 1378 (x0,x1,x2,x3,x5,xs)``; 1379 1380val mc_add_const_thm = prove( 1381 ``mc_add_const_pre (x2,x3,bc_state_tree bc,xs) /\ 1382 (mc_add_const (x2,x3,bc_state_tree bc,xs) = 1383 (Sym "NIL",Sym "NIL",x2,x3,bc_state_tree (BC_ADD_CONST bc x2),xs))``, 1384 SIMP_TAC std_ss [const_tree_def,mc_add_const_def,mc_add_const_pre_def,LET_DEF,CAR_def, 1385 mc_btree_insert_thm,CDR_def,LISP_ADD_def,getVal_def,btree_insert_tr_thm, 1386 btree_insert_thm,TL,HD,bc_state_tree_def,SExp_11,isVal_def,isDot_def,NOT_CONS_NIL] 1387 \\ REPEAT STRIP_TAC \\ SIMP_TAC (srw_ss()) [BC_ADD_CONST_def]); 1388 1389*) 1390 1391 1392(* popn and pops *) 1393 1394val (_,mc_pops_def,mc_pops_pre_def) = compile "x64" `` 1395 mc_pops (x0,code) = 1396 if x0 = Val 0 then (x0,code) else 1397 let code = WRITE_CODE code [iPOPS (getVal x0)] in 1398 (x0,code)``; 1399 1400val (_,mc_popn_def,mc_popn_pre_def) = compile "x64" `` 1401 mc_popn (x0,code) = 1402 if x0 = Val 0 then let x0 = Sym "NIL" in (x0,code) else 1403 let x0 = LISP_SUB x0 (Val 1) in 1404 let (x0,code) = mc_pops (x0,code) in 1405 let code = WRITE_CODE code [iPOP] in 1406 let x0 = Sym "NIL" in 1407 (x0,code)``; 1408 1409val mc_pops_thm = prove( 1410 ``mc_pops_pre (Val n,code) /\ 1411 (mc_pops (Val n,code) = (Val n, WRITE_CODE code (gen_pops n)))``, 1412 SRW_TAC [] [mc_pops_def,mc_pops_pre_def,gen_pops_def,LET_DEF, 1413 WRITE_CODE_NIL,getVal_def,isVal_def]); 1414 1415val mc_popn_thm = prove( 1416 ``mc_popn_pre (Val n,code) /\ 1417 (mc_popn (Val n,code) = (Sym "NIL", WRITE_CODE code (gen_popn n)))``, 1418 SRW_TAC [] [mc_popn_def,mc_popn_pre_def,LET_DEF,LISP_SUB_def,WRITE_CODE_APPEND, 1419 WRITE_CODE_NIL,getVal_def,isVal_def,mc_pops_thm,gen_popn_def]); 1420 1421 1422(* drop *) 1423 1424val (_,mc_drop_def,mc_drop_pre_def) = compile "x64" `` 1425 mc_drop (x0,x3) = 1426 if ~(isDot x3) then let x0 = Sym "NIL" in (x0,x3) else 1427 if x0 = Val 0 then let x0 = Sym "NIL" in (x0,x3) else 1428 let x0 = LISP_SUB x0 (Val 1) in 1429 let x3 = SAFE_CDR x3 in 1430 mc_drop (x0,x3)``; 1431 1432val mc_drop_thm = prove( 1433 ``!a n. 1434 mc_drop_pre (Val n,a2sexp a) /\ 1435 (mc_drop (Val n,a2sexp a) = (Sym "NIL", a2sexp (DROP n a)))``, 1436 Induct \\ ONCE_REWRITE_TAC [mc_drop_def,mc_drop_pre_def] 1437 \\ SIMP_TAC std_ss [DROP_def,a2sexp_def,MAP,list2sexp_def,SExp_distinct,SExp_11,isDot_def] 1438 \\ REPEAT STRIP_TAC \\ Cases_on `n = 0` \\ ASM_SIMP_TAC std_ss [LET_DEF] 1439 \\ FULL_SIMP_TAC std_ss [MAP,a2sexp_def,list2sexp_def,CDR_def,LISP_SUB_def, 1440 getVal_def,isVal_def,SAFE_CDR_def]); 1441 1442 1443(* length *) 1444 1445val (_,mc_length_def,mc_length_pre_def) = compile "x64" `` 1446 mc_length (x0,x1) = 1447 if ~(isDot x0) then (x0,x1) else 1448 let x0 = CDR x0 in 1449 let x1 = LISP_ADD x1 (Val 1) in 1450 mc_length (x0,x1)`` 1451 1452val mc_length_thm = prove( 1453 ``!xs n. 1454 mc_length_pre (list2sexp xs,Val n) /\ 1455 (mc_length (list2sexp xs,Val n) = (Sym "NIL",Val (n + LENGTH xs)))``, 1456 Induct \\ ASM_SIMP_TAC std_ss [list2sexp_def,Once mc_length_def,isDot_def, 1457 LENGTH,CDR_def,LISP_ADD_def,getVal_def,Once mc_length_pre_def,LET_DEF,isVal_def] 1458 \\ SIMP_TAC std_ss [AC ADD_ASSOC ADD_COMM,ADD1]); 1459 1460 1461(* append the reverse onto alist *) 1462 1463val (_,mc_rev_append_def,mc_rev_append_pre_def) = compile "x64" `` 1464 mc_rev_append (x0,x1,x3) = 1465 if ~(isDot x0) then (let x1 = x0 in (x0,x1,x3)) else 1466 let x1 = x0 in 1467 let x0 = x3 in 1468 let x3 = CAR x1 in 1469 let x3 = Dot x3 x0 in 1470 let x0 = CDR x1 in 1471 mc_rev_append (x0,x1,x3)``; 1472 1473val mc_rev_append_thm = prove( 1474 ``!xs ys y. (mc_rev_append_pre (list2sexp (MAP Sym xs),y,a2sexp ys)) /\ 1475 (mc_rev_append (list2sexp (MAP Sym xs),y,a2sexp ys) = 1476 (Sym "NIL",Sym "NIL",a2sexp (MAP ssVAR (REVERSE xs) ++ ys)))``, 1477 Induct \\ SIMP_TAC std_ss [MAP,list2sexp_def,REVERSE_DEF,APPEND,LET_DEF, 1478 Once mc_rev_append_def,Once mc_rev_append_pre_def,isDot_def, 1479 CAR_def,CDR_def,SAFE_CAR_def,SAFE_CDR_def] 1480 \\ ASM_SIMP_TAC std_ss [MAP_APPEND,GSYM APPEND_ASSOC,MAP,LET_DEF] 1481 \\ REPEAT STRIP_TAC 1482 \\ POP_ASSUM (ASSUME_TAC o Q.SPECL [`[ssVAR h] ++ ys`,`Dot (Sym h) (list2sexp (MAP Sym xs))`]) 1483 \\ FULL_SIMP_TAC std_ss [a2sexp_def,MAP,a2sexp_aux_def,list2sexp_def,APPEND]); 1484 1485 1486(* loops which write some instructions n times *) 1487 1488val (i,mc_stores_def,mc_stores_pre_def) = compile "x64" `` 1489 mc_stores (x0,x1,code) = 1490 if x1 = Val 0 then (x0,x1,code) else 1491 let x1 = LISP_SUB x1 (Val 1) in 1492 let code = WRITE_CODE code [iSTORE (getVal x0)] in 1493 mc_stores (x0,x1,code)`` 1494 1495val (_,mc_cons_list_def,mc_cons_list_pre_def) = compile "x64" `` 1496 mc_cons_list (x1,code) = 1497 if x1 = Val 0 then (x1,code) else 1498 let x1 = LISP_SUB x1 (Val 1) in 1499 let code = WRITE_CODE code [iDATA opCONS] in 1500 mc_cons_list (x1,code)`` 1501 1502val (_,mc_push_nils_def,mc_push_nils_pre_def) = compile "x64" `` 1503 mc_push_nils (x0,x1,x3,code) = 1504 if x1 = Val 0 then (x0,x1,x3,code) else 1505 let x1 = LISP_SUB x1 (Val 1) in 1506 let x0 = x3 in 1507 let x3 = Val 0 in 1508 let x3 = Dot x3 x0 in 1509 let x0 = Sym "NIL" in 1510 let code = WRITE_CODE code [iCONST_SYM (getSym x0)] in 1511 mc_push_nils (x0,x1,x3,code)`` 1512 1513val mc_stores_thm = prove( 1514 ``!n code. mc_stores_pre (Val k,Val n,code) /\ 1515 (mc_stores (Val k,Val n,code) = 1516 (Val k, Val 0, WRITE_CODE code (n_times n (iSTORE k))))``, 1517 Induct \\ ASM_SIMP_TAC (srw_ss()) [Once mc_stores_def, 1518 Once mc_stores_pre_def,n_times_def,LET_DEF,isVal_def, 1519 WRITE_CODE_NIL,LISP_SUB_def,getVal_def,WRITE_CODE_APPEND]); 1520 1521val mc_cons_list_thm = prove( 1522 ``!n code. mc_cons_list_pre (Val n,code) /\ 1523 (mc_cons_list (Val n,code) = 1524 (Val 0, WRITE_CODE code (n_times n (iDATA opCONS))))``, 1525 Induct \\ ASM_SIMP_TAC (srw_ss()) [Once mc_cons_list_def, 1526 Once mc_cons_list_pre_def,n_times_def,LET_DEF,isVal_def, 1527 WRITE_CODE_NIL,LISP_SUB_def,getVal_def,WRITE_CODE_APPEND]); 1528 1529val n_times_LEMMA = prove( 1530 ``!n x ys. n_times n x ++ x::ys = x::(n_times n x ++ ys)``, 1531 Induct \\ ASM_SIMP_TAC std_ss [n_times_def,APPEND]); 1532 1533val mc_push_nils_thm = prove( 1534 ``!n a code. 1535 mc_push_nils_pre (Sym "NIL",Val n,a2sexp a,code) /\ 1536 (mc_push_nils (Sym "NIL",Val n,a2sexp a,code) = 1537 (Sym "NIL", Val 0, a2sexp (n_times n ssTEMP ++ a), 1538 WRITE_CODE code (n_times n (iCONST_SYM "NIL"))))``, 1539 Induct \\ ASM_SIMP_TAC (srw_ss()) [Once mc_push_nils_def,getSym_def, 1540 Once mc_push_nils_pre_def,n_times_def,LET_DEF,isSym_def,isVal_def, 1541 WRITE_CODE_NIL,LISP_SUB_def,getVal_def,WRITE_CODE_APPEND] 1542 \\ REPEAT STRIP_TAC \\ POP_ASSUM (ASSUME_TAC o Q.SPEC `ssTEMP::a`) 1543 \\ FULL_SIMP_TAC std_ss [a2sexp_def,a2sexp_aux_def,MAP,list2sexp_def, 1544 WRITE_CODE_APPEND,APPEND,n_times_LEMMA]); 1545 1546 1547(* write primitive instruction *) 1548 1549val (_,mc_primitive_def,mc_primitivie_pre_def) = compile "x64" `` 1550 mc_primitive (x0,x1,code) = 1551 if x1 = Val 2 then 1552 if x0 = Sym "CONS" then 1553 let code = WRITE_CODE code [iDATA opCONS] in (x0,x1,code) else 1554 if x0 = Sym "EQUAL" then 1555 let code = WRITE_CODE code [iDATA opEQUAL] in (x0,x1,code) else 1556 if x0 = Sym "<" then 1557 let code = WRITE_CODE code [iDATA opLESS] in (x0,x1,code) else 1558 if x0 = Sym "SYMBOL-<" then 1559 let code = WRITE_CODE code [iDATA opSYMBOL_LESS] in (x0,x1,code) else 1560 if x0 = Sym "+" then 1561 let code = WRITE_CODE code [iDATA opADD] in (x0,x1,code) else 1562 if x0 = Sym "-" then 1563 let code = WRITE_CODE code [iDATA opSUB] in (x0,x1,code) else 1564 (* incorrect arity *) 1565 let code = WRITE_CODE code [iFAIL] in (x0,x1,code) else 1566 if x1 = Val 1 then 1567 if x0 = Sym "CONSP" then 1568 let code = WRITE_CODE code [iDATA opCONSP] in (x0,x1,code) else 1569 if x0 = Sym "NATP" then 1570 let code = WRITE_CODE code [iDATA opNATP] in (x0,x1,code) else 1571 if x0 = Sym "SYMBOLP" then 1572 let code = WRITE_CODE code [iDATA opSYMBOLP] in (x0,x1,code) else 1573 if x0 = Sym "CAR" then 1574 let code = WRITE_CODE code [iDATA opCAR] in (x0,x1,code) else 1575 if x0 = Sym "CDR" then 1576 let code = WRITE_CODE code [iDATA opCDR] in (x0,x1,code) else 1577 (* incorrect arity *) 1578 let code = WRITE_CODE code [iFAIL] in (x0,x1,code) else 1579 (* incorrect arity *) 1580 let code = WRITE_CODE code [iFAIL] in (x0,x1,code)``; 1581 1582 1583(* check function name *) 1584 1585val BC_is_reserved_name_def = Define ` 1586 BC_is_reserved_name exp = 1587 if MEM exp (MAP Sym macro_names) then Val 0 else 1588 if MEM exp (MAP Sym reserved_names) then exp else Sym "NIL"`; 1589 1590val (_,mc_is_reserved_name_def,mc_is_reserved_name_pre_def) = compile "x64" `` 1591 mc_is_reserved_name (x0) = 1592 if x0 = Sym "LET" then let x0 = Val 0 in x0 else 1593 if x0 = Sym "LET*" then let x0 = Val 0 in x0 else 1594 if x0 = Sym "COND" then let x0 = Val 0 in x0 else 1595 if x0 = Sym "AND" then let x0 = Val 0 in x0 else 1596 if x0 = Sym "FIRST" then let x0 = Val 0 in x0 else 1597 if x0 = Sym "SECOND" then let x0 = Val 0 in x0 else 1598 if x0 = Sym "THIRD" then let x0 = Val 0 in x0 else 1599 if x0 = Sym "FOURTH" then let x0 = Val 0 in x0 else 1600 if x0 = Sym "FIFTH" then let x0 = Val 0 in x0 else 1601 if x0 = Sym "LIST" then let x0 = Val 0 in x0 else 1602 if x0 = Sym "DEFUN" then let x0 = Val 0 in x0 else 1603 if x0 = Sym "QUOTE" then x0 else 1604 if x0 = Sym "IF" then x0 else 1605 if x0 = Sym "OR" then x0 else 1606 if x0 = Sym "DEFINE" then x0 else 1607 if x0 = Sym "PRINT" then x0 else 1608 if x0 = Sym "ERROR" then x0 else 1609 if x0 = Sym "FUNCALL" then x0 else 1610 if x0 = Sym "CAR" then x0 else 1611 if x0 = Sym "CDR" then x0 else 1612 if x0 = Sym "SYMBOLP" then x0 else 1613 if x0 = Sym "NATP" then x0 else 1614 if x0 = Sym "CONSP" then x0 else 1615 if x0 = Sym "+" then x0 else 1616 if x0 = Sym "-" then x0 else 1617 if x0 = Sym "SYMBOL-<" then x0 else 1618 if x0 = Sym "<" then x0 else 1619 if x0 = Sym "EQUAL" then x0 else 1620 if x0 = Sym "CONS" then x0 else 1621 let x0 = Sym "NIL" in x0`` 1622 1623val mc_is_reserved_name_thm = prove( 1624 ``!exp. mc_is_reserved_name exp = BC_is_reserved_name exp``, 1625 SIMP_TAC std_ss [mc_is_reserved_name_def,BC_is_reserved_name_def, 1626 macro_names_def,MEM,MAP,reserved_names_def,APPEND,LET_DEF] 1627 \\ SRW_TAC [] [] \\ FULL_SIMP_TAC std_ss []); 1628 1629val NOT_isFun_IMP_guard = prove( 1630 ``~isFun fc ==> 1631 ~(BC_is_reserved_name (CAR (term2sexp (App fc xs))) = Sym "NIL") /\ 1632 ~(BC_is_reserved_name (HD (func2sexp fc)) = Sym "NIL") /\ 1633 ~(BC_is_reserved_name (CAR (term2sexp (App fc xs))) = Val 0)``, 1634 Cases_on `fc` \\ FULL_SIMP_TAC std_ss [isFun_def] 1635 \\ REPEAT (Cases_on `l`) \\ EVAL_TAC); 1636 1637val BC_is_reserved_name_Fun = prove( 1638 ``BC_is_reserved_name (CAR (term2sexp (App (Fun fc) xs))) = Sym "NIL"``, 1639 SIMP_TAC std_ss [term2sexp_def,BC_is_reserved_name_def,func2sexp_def] 1640 \\ Cases_on `MEM fc reserved_names` \\ ASM_SIMP_TAC std_ss [] 1641 \\ FULL_SIMP_TAC std_ss [APPEND,list2sexp_def,CAR_def] 1642 \\ EVAL_TAC \\ FULL_SIMP_TAC std_ss [MEM,reserved_names_def,macro_names_def,APPEND] 1643 \\ EVAL_TAC \\ FULL_SIMP_TAC std_ss [MEM,reserved_names_def,APPEND]); 1644 1645 1646(* strip application *) 1647 1648val (_,mc_strip_app_def,mc_strip_app_pre_def) = compile "x64" `` 1649 mc_strip_app (x0:SExp,x1:SExp) = 1650 let x0 = CAR x1 in 1651 if ~(isVal x0) then (x0,x1) else 1652 let x1 = CDR x1 in (x0,x1)`` 1653 1654val mc_strip_app_thm = prove( 1655 ``mc_strip_app_pre (x,term2sexp (App (Fun fc) xs)) /\ 1656 (mc_strip_app (x,term2sexp (App (Fun fc) xs)) = 1657 (CAR (term2sexp (App (Fun fc) xs)), 1658 list2sexp (Sym fc :: MAP term2sexp xs)))``, 1659 SIMP_TAC std_ss [term2sexp_def,func2sexp_def] 1660 \\ Cases_on `MEM fc reserved_names` \\ POP_ASSUM MP_TAC 1661 \\ ASM_SIMP_TAC std_ss [mc_strip_app_def,mc_strip_app_pre_def,LET_DEF] 1662 \\ ASM_SIMP_TAC std_ss [] \\ EVAL_TAC \\ ASM_SIMP_TAC std_ss [] 1663 \\ EVAL_TAC \\ ASM_SIMP_TAC std_ss []); 1664 1665 1666(* return code *) 1667 1668val (_,mc_return_code_def,mc_return_code_pre_def) = compile "x64" `` 1669 mc_return_code (x0:SExp,x1:SExp,x3,x4,code) = 1670 if x4 (* ret *) = Sym "NIL" then 1671 let x0 = Sym "NIL" in 1672 let x1 = Sym "NIL" in 1673 (x0,x1,x3,x4,code) 1674 else 1675 let x1 = Val 0 in 1676 let x0 = x3 in 1677 let (x0,x1) = mc_length (x0,x1) in 1678 let x0 = x1 in 1679 let x1 = Val 1 in 1680 let x0 = LISP_SUB x0 x1 in 1681 let (x0,code) = mc_pops (x0,code) in 1682 let code = WRITE_CODE code [iRETURN] in 1683 let x0 = Sym "NIL" in 1684 let x1 = Sym "NIL" in 1685 (x0,x1,x3,x4,code)`` 1686 1687val mc_return_code_thm = prove( 1688 ``mc_return_code_pre (x0,x1,a2sexp a,bool2sexp ret,code) /\ 1689 (mc_return_code (x0,x1,a2sexp a,bool2sexp ret,code) = 1690 (Sym "NIL",Sym "NIL",a2sexp a,bool2sexp ret,WRITE_CODE code (BC_return_code ret a)))``, 1691 Cases_on `ret` \\ FULL_SIMP_TAC std_ss [mc_return_code_def,LET_DEF,bool2sexp_def, 1692 mc_return_code_pre_def] 1693 \\ FULL_SIMP_TAC (srw_ss()) [a2sexp_def,mc_length_thm,LISP_SUB_def,isVal_def, 1694 getVal_def,mc_pops_thm,WRITE_CODE_APPEND,BC_return_code_def,WRITE_CODE_NIL]); 1695 1696 1697(* lookup variable location *) 1698 1699val (_,mc_alist_lookup_def,mc_alist_lookup_pre_def) = compile "x64" `` 1700 mc_alist_lookup (x0,x1,x2,x3) = 1701 if ~(isDot x3) then let x1 = Sym "NIL" in (x0,x1,x2,x3) else 1702 let x0 = CAR x3 in 1703 if x0 = x2 then (x0,x1,x2,x3) else 1704 let x1 = LISP_ADD x1 (Val 1) in 1705 let x3 = CDR x3 in 1706 mc_alist_lookup (x0,x1,x2,x3)`` 1707 1708val mc_alist_lookup_thm = prove( 1709 ``!a v n k x0. 1710 (var_lookup k v a = SOME n) ==> 1711 ?y0 y1 y3. 1712 mc_alist_lookup_pre (x0,Val k,Sym v,a2sexp a) /\ 1713 (mc_alist_lookup (x0,Val k,Sym v,a2sexp a) = (y0,Val n,y1,y3))``, 1714 Induct \\ SIMP_TAC std_ss [var_lookup_def] \\ REPEAT STRIP_TAC 1715 \\ Cases_on `h` \\ FULL_SIMP_TAC (srw_ss()) [] 1716 \\ ONCE_REWRITE_TAC [mc_alist_lookup_def,mc_alist_lookup_pre_def] 1717 \\ FULL_SIMP_TAC (srw_ss()) [a2sexp_def,a2sexp_aux_def,MAP,list2sexp_def, 1718 CAR_def,CDR_def,LISP_ADD_def,getVal_def,isDot_def,LET_DEF,isVal_def, 1719 markerTheory.Abbrev_def] \\ RES_TAC \\ FULL_SIMP_TAC std_ss [] 1720 \\ Cases_on `s = v` \\ FULL_SIMP_TAC std_ss [getVal_def,SExp_11]); 1721 1722val mc_alist_lookup_NONE = prove( 1723 ``!a v n k x0. 1724 (var_lookup k v a = NONE) ==> 1725 ?y0 y1 y3. 1726 mc_alist_lookup_pre (x0,Val k,Sym v,a2sexp a) /\ 1727 (mc_alist_lookup (x0,Val k,Sym v,a2sexp a) = (y0,Sym "NIL",y1,y3))``, 1728 Induct \\ SIMP_TAC std_ss [var_lookup_def] \\ REPEAT STRIP_TAC 1729 \\ REPEAT (Cases_on `h` \\ FULL_SIMP_TAC (srw_ss()) []) 1730 \\ ONCE_REWRITE_TAC [mc_alist_lookup_def,mc_alist_lookup_pre_def] 1731 \\ FULL_SIMP_TAC (srw_ss()) [a2sexp_def,a2sexp_aux_def,MAP,list2sexp_def, 1732 CAR_def,CDR_def,LISP_ADD_def,getVal_def,isDot_def,LET_DEF,isVal_def, 1733 markerTheory.Abbrev_def] 1734 \\ Cases_on `s = v` \\ FULL_SIMP_TAC std_ss [getVal_def,SExp_11]); 1735 1736 1737(* lookup function location *) 1738 1739val (_,mc_fun_lookup_def,mc_fun_lookup_pre_def) = compile "x64" `` 1740 mc_fun_lookup (x0,x1,x2) = 1741 if ~(isDot x1) then (x0,x1,x2) else 1742 let x0 = CAR x1 in 1743 let x1 = CDR x1 in 1744 if x0 = x2 then 1745 let x1 = CAR x1 in 1746 (x0,x1,x2) 1747 else 1748 let x1 = CDR x1 in 1749 mc_fun_lookup (x0,x1,x2)`` 1750 1751val lookup_result_def = Define ` 1752 (lookup_result NONE = Sym "NIL") /\ 1753 (lookup_result (SOME (x,y)) = Dot (Val x) (Val y))`; 1754 1755val mc_fun_lookup_thm = prove( 1756 ``!xs y fc. ?y0 y1. 1757 mc_fun_lookup_pre (y,list2sexp (flat_alist xs),Sym fc) /\ 1758 (mc_fun_lookup (y,list2sexp (flat_alist xs),Sym fc) = 1759 (y0,lookup_result (FUN_LOOKUP xs fc),y1))``, 1760 Induct \\ SIMP_TAC std_ss [flat_alist_def,list2sexp_def] 1761 \\ ONCE_REWRITE_TAC [mc_fun_lookup_def,mc_fun_lookup_pre_def] 1762 \\ SIMP_TAC std_ss [isDot_def,FUN_LOOKUP_def,lookup_result_def] 1763 \\ Cases_on `h` \\ Cases_on `r` \\ SIMP_TAC (srw_ss()) [isDot_def,FUN_LOOKUP_def, 1764 lookup_result_def,LET_DEF,flat_alist_def,list2sexp_def,CAR_def,CDR_def, 1765 markerTheory.Abbrev_def] \\ REPEAT STRIP_TAC 1766 \\ Cases_on `q = fc` \\ FULL_SIMP_TAC std_ss [lookup_result_def]); 1767 1768val mc_fun_lookup_NONE_bc = prove( 1769 ``bc_inv bc /\ (FUN_LOOKUP bc.compiled fc = NONE) ==> 1770 ?y0 y1. 1771 mc_fun_lookup_pre (x0,CDR (bc_state_tree bc),Sym fc) /\ 1772 (mc_fun_lookup (x0,CDR (bc_state_tree bc),Sym fc) = (y0,Sym "NIL",y1))``, 1773 FULL_SIMP_TAC std_ss [bc_inv_def,bc_state_tree_def,CDR_def] 1774 \\ METIS_TAC [mc_fun_lookup_thm,lookup_result_def]); 1775 1776val mc_fun_lookup_SOME_bc = prove( 1777 ``bc_inv bc /\ (FUN_LOOKUP bc.compiled fc = SOME (n,m)) ==> 1778 ?y0 y1. 1779 mc_fun_lookup_pre (x0,CDR (bc_state_tree bc),Sym fc) /\ 1780 (mc_fun_lookup (x0,CDR (bc_state_tree bc),Sym fc) = (y0,Dot (Val n) (Val m),y1))``, 1781 FULL_SIMP_TAC std_ss [bc_inv_def,bc_state_tree_def,CDR_def] 1782 \\ METIS_TAC [mc_fun_lookup_thm,lookup_result_def]); 1783 1784 1785(* implementation of iCALL_SYM (and iJUMP_SYM) *) 1786 1787val (mc_fun_lookup_full_spec,mc_fun_lookup_full_def,mc_fun_lookup_full_pre_def) = compile "x64" `` 1788 mc_fun_lookup_full (x0,x1:SExp,x2,x5,(xs:SExp list),io) = 1789 let x1 = CDR x5 in 1790 let x2 = x0 in 1791 let (x0,x1,x2) = mc_fun_lookup (x0,x1,x2) in 1792 if ~(isDot x1) then 1793 let x0 = x2 in 1794 let io = IO_WRITE io (sexp2string x0) in 1795 let io = IO_WRITE io "\n" in 1796 let x0 = no_such_function x0 in 1797 (x0,x1,x2,x5,xs,io) 1798 else 1799 let x2 = CAR x1 in 1800 let x1 = CDR x1 in 1801 let x0 = HD xs in 1802 if ~(x0 = x1) then 1803 let x0 = x2 in 1804 let io = IO_WRITE io (sexp2string x0) in 1805 let io = IO_WRITE io "\n" in 1806 let x0 = no_such_function x0 in 1807 (x0,x1,x2,x5,xs,io) 1808 else 1809 let x1 = x2 in 1810 let xs = TL xs in 1811 let x0 = HD xs in 1812 let xs = TL xs in 1813 (x0,x1,x2,x5,xs,io)`` 1814 1815val mc_fun_lookup_full_thm = prove( 1816 ``bc_inv bc /\ (FUN_LOOKUP bc.compiled fc = SOME (i,m)) ==> 1817 mc_fun_lookup_full_pre (Sym fc,x1,x2,bc_state_tree bc,Val m::x::xs,io) /\ 1818 (mc_fun_lookup_full (Sym fc,x1,x2,bc_state_tree bc,Val m::x::xs,io) = 1819 (x,Val i,Val i,bc_state_tree bc,xs,io))``, 1820 SIMP_TAC std_ss [mc_fun_lookup_full_def,mc_fun_lookup_full_pre_def,LET_DEF,TL,HD] 1821 \\ REPEAT STRIP_TAC 1822 \\ IMP_RES_TAC mc_fun_lookup_SOME_bc 1823 \\ POP_ASSUM (STRIP_ASSUME_TAC o Q.SPEC `Sym fc`) 1824 \\ ASM_SIMP_TAC std_ss [NOT_CONS_NIL,isVal_def] 1825 \\ FULL_SIMP_TAC std_ss [bc_state_tree_def,isDot_def,CDR_def,markerTheory.Abbrev_def,CAR_def]); 1826 1827(* 1828val th = mc_fun_lookup_full_spec 1829 |> Q.INST [`x0`|->`Sym fc`,`x5`|->`bc_state_tree bc`,`xs`|->`Val k::x::xs`] 1830 |> DISCH ``bc_inv bc /\ (FUN_LOOKUP bc.compiled fc = SOME (i,m))`` 1831 |> SIMP_RULE std_ss [mc_fun_lookup_full_thm] 1832 |> UNDISCH 1833 |> CONV_RULE (REWRITE_CONV [UNDISCH mc_fun_lookup_full_thm]) 1834 |> SIMP_RULE std_ss [LET_DEF] 1835 |> DISCH_ALL |> SIMP_RULE (std_ss++sep_cond_ss) [GSYM SPEC_MOVE_COND] 1836 |> (fn th => SPEC_COMPOSE_RULE [th,X64_LISP_JUMP_TO_CODE]) 1837 |> SIMP_RULE std_ss [isVal_def,getVal_def,SEP_CLAUSES] 1838 (* followed by either jmp r2 or call r2 *) 1839*) 1840 1841 1842(* map car and map car_cdr *) 1843 1844val (_,mc_map_car1_def,mc_map_car1_pre_def) = compile "x64" `` 1845 mc_map_car1 (x0,x1,x2,x3,xs) = 1846 if ~(isDot x0) then 1847 let x1 = Sym "NIL" in 1848 let x2 = Sym "NIL" in 1849 (x0,x1,x2,x3,xs) 1850 else 1851 let x1 = CAR x0 in 1852 let x2 = SAFE_CDR x1 in 1853 let x2 = SAFE_CAR x2 in 1854 let xs = x2::xs in 1855 let x1 = SAFE_CAR x1 in 1856 let xs = x1::xs in 1857 let x3 = LISP_ADD x3 (Val 1) in 1858 let x0 = CDR x0 in 1859 mc_map_car1 (x0,x1,x2,x3,xs)`` 1860 1861val (_,mc_map_car2_def,mc_map_car2_pre_def) = compile "x64" `` 1862 mc_map_car2 (x0,x1,x2,x3,xs) = 1863 if x3 = Val 0 then let x0 = Sym "NIL" in (x0,x1,x2,x3,xs) else 1864 let x0 = x1 in 1865 let x1 = HD xs in 1866 let x1 = Dot x1 x0 in 1867 let xs = TL xs in 1868 let x0 = x2 in 1869 let x2 = HD xs in 1870 let x2 = Dot x2 x0 in 1871 let xs = TL xs in 1872 let x3 = LISP_SUB x3 (Val 1) in 1873 mc_map_car2 (x0,x1,x2,x3,xs)`` 1874 1875val (_,mc_map_car_def,mc_map_car_pre_def) = compile "x64" `` 1876 mc_map_car (x0:SExp,x1:SExp,x2:SExp,x3:SExp,xs:SExp list) = 1877 let x3 = Val 0 in 1878 let (x0,x1,x2,x3,xs) = mc_map_car1 (x0,x1,x2,x3,xs) in 1879 let (x0,x1,x2,x3,xs) = mc_map_car2 (x0,x1,x2,x3,xs) in 1880 (x0,x1,x2,x3,xs)`` 1881 1882val map_car_flatten_def = Define ` 1883 (map_car_flatten [] = []) /\ 1884 (map_car_flatten (x::xs) = CAR x :: CAR (CDR x) :: map_car_flatten xs)`; 1885 1886val map_car_flatten_APPEND = prove( 1887 ``!xs ys. map_car_flatten (xs ++ ys) = map_car_flatten xs ++ map_car_flatten ys``, 1888 Induct \\ FULL_SIMP_TAC std_ss [map_car_flatten_def,APPEND]); 1889 1890val mc_map_car1_thm = prove( 1891 ``!x0 x1 x2 n xs. ?y. 1892 mc_map_car1_pre (x0,x1,x2,Val n,xs) /\ 1893 (mc_map_car1 (x0,x1,x2,Val n,xs) = 1894 (y, Sym "NIL", Sym "NIL", Val (LENGTH (sexp2list x0) + n), 1895 map_car_flatten (REVERSE (sexp2list x0)) ++ xs))``, 1896 Induct \\ ONCE_REWRITE_TAC [mc_map_car1_def,mc_map_car1_pre_def] 1897 \\ ASM_SIMP_TAC std_ss [list2sexp_def,map_car_flatten_def,APPEND,LENGTH, 1898 LET_DEF,isDot_def,CAR_def,CDR_def,LISP_ADD_def,getVal_def,REVERSE_DEF, 1899 map_car_flatten_APPEND,GSYM APPEND_ASSOC,APPEND,isVal_def,SAFE_CAR_def, 1900 SAFE_CDR_def,sexp2list_def] 1901 \\ FULL_SIMP_TAC std_ss [AC ADD_ASSOC ADD_COMM,ADD1] 1902 \\ REPEAT STRIP_TAC 1903 \\ POP_ASSUM (STRIP_ASSUME_TAC o Q.SPECL [`CAR x0`,`CAR (CDR x0)`, 1904 `n+1`,`CAR x0::CAR (CDR x0)::xs`]) 1905 \\ FULL_SIMP_TAC std_ss [AC ADD_ASSOC ADD_COMM,ADD1]); 1906 1907val mc_map_car2_thm = prove( 1908 ``!ys ys1 ys2 x1 x2 xs. 1909 mc_map_car2_pre (x1,list2sexp ys1,list2sexp ys2,Val (LENGTH ys),map_car_flatten ys ++ xs) /\ 1910 (mc_map_car2 (x1,list2sexp ys1,list2sexp ys2,Val (LENGTH ys),map_car_flatten ys ++ xs) = 1911 (Sym "NIL", list2sexp (MAP CAR (REVERSE ys) ++ ys1), 1912 list2sexp (MAP (CAR o CDR) (REVERSE ys) ++ ys2), Val 0, xs))``, 1913 Induct \\ SIMP_TAC std_ss [] \\ ONCE_REWRITE_TAC [mc_map_car2_def,mc_map_car2_pre_def] 1914 \\ SIMP_TAC std_ss [MAP,APPEND,REVERSE_DEF,map_car_flatten_def,LENGTH,LET_DEF, 1915 SExp_11,ADD1,TL,HD,LISP_SUB_def,getVal_def] 1916 \\ ASM_SIMP_TAC std_ss [GSYM list2sexp_def,MAP_APPEND,MAP,GSYM APPEND_ASSOC, 1917 APPEND,isVal_def,NOT_CONS_NIL]); 1918 1919val mc_map_car_alternative_thm = prove( 1920 ``mc_map_car_pre (x0,x1,x2,x3,xs) /\ 1921 (mc_map_car (x0,x1,x2,x3,xs) = 1922 (Sym "NIL", list2sexp (MAP CAR (sexp2list x0)), 1923 list2sexp (MAP (CAR o CDR) (sexp2list x0)), Val 0, xs))``, 1924 SIMP_TAC std_ss [mc_map_car_def,mc_map_car_pre_def,LET_DEF] 1925 \\ STRIP_ASSUME_TAC (Q.SPECL [`x0`,`x1`,`x2`,`0`,`xs`] mc_map_car1_thm) 1926 \\ ASM_SIMP_TAC std_ss [] \\ ONCE_REWRITE_TAC [GSYM LENGTH_REVERSE] 1927 \\ SIMP_TAC std_ss [GSYM list2sexp_def,mc_map_car2_thm,REVERSE_REVERSE,APPEND_NIL]); 1928 1929val mc_map_car_thm = prove( 1930 ``mc_map_car_pre (list2sexp ys,x1,x2,x3,xs) /\ 1931 (mc_map_car (list2sexp ys,x1,x2,x3,xs) = 1932 (Sym "NIL", list2sexp (MAP CAR ys), list2sexp (MAP (CAR o CDR) ys), Val 0, xs))``, 1933 ASM_SIMP_TAC std_ss [mc_map_car_alternative_thm,sexp2list_list2sexp]); 1934 1935 1936(* BC_expand_macro is a readable version of mc_expand_macro *) 1937val BC_expand_macro_def = Define ` 1938 BC_expand_macro (temp:SExp,task,exp,a,ret,consts,xs) = 1939 let temp = exp in 1940 let exp = CAR exp in 1941 if exp = Sym "FIRST" then 1942 let exp = Dot (Sym "CAR") (CDR temp) in 1943 (Sym "NIL",task,exp,a,ret,consts,xs) else 1944 if exp = Sym "SECOND" then 1945 let exp = Dot (Sym "FIRST") (Dot (Dot (Sym "CDR") (CDR temp)) (Sym "NIL")) in 1946 (Sym "NIL",task,exp,a,ret,consts,xs) else 1947 if exp = Sym "THIRD" then 1948 let exp = Dot (Sym "SECOND") (Dot (Dot (Sym "CDR") (CDR temp)) (Sym "NIL")) in 1949 (Sym "NIL",task,exp,a,ret,consts,xs) else 1950 if exp = Sym "FOURTH" then 1951 let exp = Dot (Sym "THIRD") (Dot (Dot (Sym "CDR") (CDR temp)) (Sym "NIL")) in 1952 (Sym "NIL",task,exp,a,ret,consts,xs) else 1953 if exp = Sym "FIFTH" then 1954 let exp = Dot (Sym "FOURTH") (Dot (Dot (Sym "CDR") (CDR temp)) (Sym "NIL")) in 1955 (Sym "NIL",task,exp,a,ret,consts,xs) else 1956 if exp = Sym "LET" then 1957 let xs = a::ret::consts::xs in 1958 let (nil,vars,exps,zero,xs) = mc_map_car (CAR (CDR temp), exp, exp, exp, xs) in 1959 let lam = Dot (Sym "LAMBDA") (Dot vars (Dot (CAR (CDR (CDR temp))) (Sym "NIL"))) in 1960 let exp = Dot lam exps in 1961 let a = HD xs in 1962 let xs = TL xs in 1963 let ret = HD xs in 1964 let xs = TL xs in 1965 let consts = HD xs in 1966 let xs = TL xs in 1967 let task = Sym "NIL" in 1968 (Sym "NIL",task,exp,a,ret,consts,xs) else 1969 if exp = Sym "LET*" then 1970 let exp = CAR (CDR temp) in 1971 (if exp = Sym "NIL" then 1972 let exp = CAR (CDR (CDR temp)) in 1973 (Sym "NIL",task,exp,a,ret,consts,xs) 1974 else 1975 let rest = CDR exp in 1976 let head = CAR exp in 1977 let let_star = Dot (Sym "LET*") (Dot rest (Dot (CAR (CDR (CDR temp))) (Sym "NIL"))) in 1978 let assigns = Dot head (Sym "NIL") in 1979 let exp = Dot (Sym "LET") (Dot assigns (Dot (let_star) (Sym "NIL"))) in 1980 (Sym "NIL",task,exp,a,ret,consts,xs)) else 1981 if exp = Sym "COND" then 1982 let exp = CDR temp in 1983 (if exp = Sym "NIL" then 1984 let exp = Dot (Sym "QUOTE") (Dot (Sym "NIL") (Sym "NIL")) in 1985 (Sym "NIL",task,exp,a,ret,consts,xs) 1986 else 1987 let rest = CDR exp in 1988 let head = CAR exp in 1989 let rest = Dot (Sym "COND") rest in 1990 let exp = Dot (CAR (CDR head)) (Dot rest (Sym "NIL")) in 1991 let exp = Dot (Sym "IF") (Dot (CAR head) exp) in 1992 (Sym "NIL",task,exp,a,ret,consts,xs)) else 1993 if exp = Sym "AND" then 1994 let exp = CDR temp in 1995 (if exp = Sym "NIL" then 1996 let exp = Dot (Sym "QUOTE") (Dot (Sym "T") (Sym "NIL")) in 1997 (Sym "NIL",task,exp,a,ret,consts,xs) 1998 else 1999 let rest = CDR exp in 2000 let head = CAR exp in 2001 if isDot rest then 2002 let exp = list2sexp 2003 [Sym "IF"; head; 2004 Dot (Sym "AND") rest; 2005 list2sexp [Sym "QUOTE"; list2sexp []]] in 2006 (Sym "NIL",task,exp,a,ret,consts,xs) 2007 else 2008 let exp = head in 2009 (Sym "NIL",task,exp,a,ret,consts,xs)) else 2010 if exp = Sym "LIST" then 2011 let exp = CDR temp in 2012 (if exp = Sym "NIL" then 2013 let exp = Dot (Sym "QUOTE") (Dot (Sym "NIL") (Sym "NIL")) in 2014 (Sym "NIL",task,exp,a,ret,consts,xs) 2015 else 2016 let rest = CDR exp in 2017 let head = CAR exp in 2018 let exp = list2sexp 2019 [Sym "CONS"; head; 2020 Dot (Sym "LIST") rest] in 2021 (Sym "NIL",task,exp,a,ret,consts,xs)) else 2022 if exp = Sym "DEFUN" then 2023 (let arg1 = list2sexp [Sym "QUOTE"; CAR (CDR temp)] in 2024 let arg2 = list2sexp [Sym "QUOTE"; CAR (CDR (CDR temp))] in 2025 let arg3 = list2sexp [Sym "QUOTE"; CAR (CDR (CDR (CDR temp)))] in 2026 let exp = list2sexp [Sym "DEFINE"; arg1; arg2; arg3] in 2027 (Sym "NIL",task,exp,a,ret,consts,xs)) else 2028 (Sym "NIL",task,temp,a,ret,consts,xs)`; 2029 2030fun sexp_lets exp = let 2031 val expand = (cdr o concl o SIMP_CONV std_ss [list2sexp_def]) 2032 fun flatten exp = 2033 if is_var exp then ([],exp) else 2034 if can (match_term ``Dot x y``) exp then let 2035 val (xs1,x1) = flatten (cdr (car exp)) 2036 val (xs2,x2) = flatten (cdr exp) 2037 val v = genvar(``:SExp``) 2038 val new_exp = mk_comb(``Dot x0``,x2) 2039 in (xs2 @ xs1 @ [(``x0:SExp``,x1),(``x0:SExp``,new_exp),(v,``x0:SExp``)], v) end else 2040 if can (match_term ``CAR x``) exp then let 2041 val (xs1,x1) = flatten (cdr exp) 2042 val v = genvar(``:SExp``) 2043 val new_exp = mk_comb(``CAR``,x1) 2044 in (xs1 @ [(v,new_exp)], v) end else 2045 if can (match_term ``CDR x``) exp then let 2046 val (xs1,x1) = flatten (cdr exp) 2047 val v = genvar(``:SExp``) 2048 val new_exp = mk_comb(``CDR``,x1) 2049 in (xs1 @ [(v,new_exp)], v) end else 2050 if ((can (match_term ``Sym "NIL"``) exp) orelse 2051 (can (match_term ``Sym "T"``) exp)) then let 2052 val v = genvar(``:SExp``) 2053 in ([(v,exp)], v) end else 2054 if can (match_term ``Sym x``) exp then let 2055 val v = genvar(``:SExp``) 2056 in ([(``x0:SExp``,exp),(v,``x0:SExp``)], v) end else 2057 ([],exp) 2058 val regs = [``x2:SExp``,``x1:SExp``,``x3:SExp``,``x4:SExp``,``x5:SExp``, 2059 ``t1:SExp``,``t2:SExp``,``t3:SExp``,``t4:SExp``,``t5:SExp``,``x0:SExp``] 2060 fun all_clashes v tm = 2061 if is_var tm then [] else let 2062 val (xs,rest) = pairSyntax.dest_anylet tm 2063 val (lhs,rhs) = hd xs 2064 in if not (mem v (free_vars rest)) then [] else 2065 free_vars lhs @ all_clashes v rest end 2066 fun select_reg lhs tm = let 2067 val vs = free_vars tm 2068 val possible_regs = if is_var tm then regs else filter (fn x => not (mem x vs)) regs 2069 val clashes = all_clashes lhs tm 2070 in hd (filter (fn x => not (mem x clashes)) regs) end 2071 fun build ([],v) = v 2072 | build ((lhs,rhs)::xs,v) = 2073 if mem lhs regs then pairSyntax.mk_anylet([(lhs,rhs)],build (xs,v)) else let 2074 val tm = build (xs,v) 2075 val reg_name = select_reg lhs tm 2076 val tm = subst [lhs |-> reg_name] tm 2077 in pairSyntax.mk_anylet([(reg_name,rhs)],tm) end 2078 fun clean_up tm = 2079 if is_var tm then tm else let 2080 val (xs,rest) = pairSyntax.dest_anylet tm 2081 val rest = clean_up rest 2082 val (lhs,rhs) = hd xs 2083 in if lhs = rhs then rest else 2084 pairSyntax.mk_anylet([(lhs,rhs)],rest) end 2085 val full = clean_up o build o flatten o expand 2086 val result = full exp 2087 val thm = SIMP_CONV std_ss [LET_DEF] (mk_eq(result,expand exp)) 2088 val _ = (cdr (concl thm) = ``T``) orelse fail() 2089 in result end 2090 2091val (_,mc_expand_macro_def,mc_expand_macro_pre_def) = compile "x64" `` 2092 mc_expand_macro (x0:SExp,x1:SExp,x2:SExp,x3:SExp,x4:SExp,x5:SExp,xs:SExp list) = 2093 let x0 = SAFE_CAR x2 in 2094 if x0 = Sym "FIRST" then 2095 let x2 = SAFE_CDR x2 in 2096 let x0 = Sym "CAR" in 2097 let x0 = Dot x0 x2 in 2098 let x2 = x0 in 2099 let x0 = Sym "NIL" in 2100 (x0,x1,x2,x3,x4,x5,xs) else 2101 if x0 = Sym "SECOND" then 2102 let x2 = SAFE_CDR x2 in 2103 let x0 = Sym "CDR" in 2104 let x0 = Dot x0 x2 in 2105 let x2 = Sym "NIL" in 2106 let x0 = Dot x0 x2 in 2107 let x2 = x0 in 2108 let x0 = Sym "FIRST" in 2109 let x0 = Dot x0 x2 in 2110 let x2 = x0 in 2111 let x0 = Sym "NIL" in 2112 (x0,x1,x2,x3,x4,x5,xs) else 2113 if x0 = Sym "THIRD" then 2114 let x2 = SAFE_CDR x2 in 2115 let x0 = Sym "CDR" in 2116 let x0 = Dot x0 x2 in 2117 let x2 = Sym "NIL" in 2118 let x0 = Dot x0 x2 in 2119 let x2 = x0 in 2120 let x0 = Sym "SECOND" in 2121 let x0 = Dot x0 x2 in 2122 let x2 = x0 in 2123 let x0 = Sym "NIL" in 2124 (x0,x1,x2,x3,x4,x5,xs) else 2125 if x0 = Sym "FOURTH" then 2126 let x2 = SAFE_CDR x2 in 2127 let x0 = Sym "CDR" in 2128 let x0 = Dot x0 x2 in 2129 let x2 = Sym "NIL" in 2130 let x0 = Dot x0 x2 in 2131 let x2 = x0 in 2132 let x0 = Sym "THIRD" in 2133 let x0 = Dot x0 x2 in 2134 let x2 = x0 in 2135 let x0 = Sym "NIL" in 2136 (x0,x1,x2,x3,x4,x5,xs) else 2137 if x0 = Sym "FIFTH" then 2138 let x2 = SAFE_CDR x2 in 2139 let x0 = Sym "CDR" in 2140 let x0 = Dot x0 x2 in 2141 let x2 = Sym "NIL" in 2142 let x0 = Dot x0 x2 in 2143 let x2 = x0 in 2144 let x0 = Sym "FOURTH" in 2145 let x0 = Dot x0 x2 in 2146 let x2 = x0 in 2147 let x0 = Sym "NIL" in 2148 (x0,x1,x2,x3,x4,x5,xs) else 2149 if x0 = Sym "LET" then 2150 let xs = x5::xs in 2151 let xs = x4::xs in 2152 let xs = x3::xs in 2153 let x4 = x2 in 2154 let x1 = x0 in 2155 let x0 = SAFE_CDR x2 in 2156 let x0 = SAFE_CAR x0 in 2157 let x2 = x1 in 2158 let x3 = x1 in 2159 let (x0,x1,x2,x3,xs) = mc_map_car (x0, x1, x2, x3, xs) in 2160 let x4 = SAFE_CDR x4 in 2161 let x4 = SAFE_CDR x4 in 2162 let x4 = SAFE_CAR x4 in 2163 let x0 = Sym "NIL" in 2164 let x4 = Dot x4 x0 in 2165 let x1 = Dot x1 x4 in 2166 let x0 = Sym "LAMBDA" in 2167 let x0 = Dot x0 x1 in 2168 let x0 = Dot x0 x2 in 2169 let x2 = x0 in 2170 let x3 = HD xs in 2171 let xs = TL xs in 2172 let x4 = HD xs in 2173 let xs = TL xs in 2174 let x5 = HD xs in 2175 let xs = TL xs in 2176 let x1 = Sym "NIL" in 2177 let x0 = Sym "NIL" in 2178 (x0,x1,x2,x3,x4,x5,xs) else 2179 if x0 = Sym "LET*" then 2180 let x0 = SAFE_CDR x2 in 2181 let x0 = SAFE_CAR x0 in 2182 (if x0 = Sym "NIL" then 2183 let x2 = SAFE_CDR x2 in 2184 let x2 = SAFE_CDR x2 in 2185 let x2 = SAFE_CAR x2 in 2186 let x0 = Sym "NIL" in 2187 (x0,x1,x2,x3,x4,x5,xs) 2188 else 2189 let xs = x5::xs in 2190 let xs = x4::xs in 2191 let xs = x3::xs in 2192 let xs = x1::xs in 2193 let x5 = x0 in 2194 let x4 = x2 in 2195 (* sexp_lets list2sexp [Sym "LET"; list2sexp [SAFE_CAR x5]; list2sexp [Sym "LET*"; SAFE_CDR x5; SAFE_CAR (SAFE_CDR (SAFE_CDR x4))]] *) 2196 let x3 = Sym "NIL" in 2197 let x1 = Sym "NIL" in 2198 let x2 = SAFE_CDR x4 in 2199 let x2 = SAFE_CDR x2 in 2200 let x2 = SAFE_CAR x2 in 2201 let x0 = x2 in 2202 let x0 = Dot x0 x1 in 2203 let x1 = x0 in 2204 let x2 = SAFE_CDR x5 in 2205 let x0 = x2 in 2206 let x0 = Dot x0 x1 in 2207 let x1 = x0 in 2208 let x0 = Sym "LET*" in 2209 let x2 = x0 in 2210 let x0 = x2 in 2211 let x0 = Dot x0 x1 in 2212 let x2 = x0 in 2213 let x0 = x2 in 2214 let x0 = Dot x0 x3 in 2215 let x3 = x0 in 2216 let x1 = Sym "NIL" in 2217 let x2 = SAFE_CAR x5 in 2218 let x0 = x2 in 2219 let x0 = Dot x0 x1 in 2220 let x2 = x0 in 2221 let x0 = x2 in 2222 let x0 = Dot x0 x3 in 2223 let x1 = x0 in 2224 let x0 = Sym "LET" in 2225 let x2 = x0 in 2226 let x0 = x2 in 2227 let x0 = Dot x0 x1 in 2228 let x2 = x0 in 2229 let x1 = HD xs in 2230 let xs = TL xs in 2231 let x3 = HD xs in 2232 let xs = TL xs in 2233 let x4 = HD xs in 2234 let xs = TL xs in 2235 let x5 = HD xs in 2236 let xs = TL xs in 2237 let x0 = Sym "NIL" in 2238 (x0,x1,x2,x3,x4,x5,xs)) else 2239 if x0 = Sym "COND" then 2240 let x0 = SAFE_CDR x2 in 2241 (if x0 = Sym "NIL" then 2242 let x0 = Sym "NIL" in 2243 let x2 = Sym "NIL" in 2244 let x2 = Dot x2 x0 in 2245 let x0 = Sym "QUOTE" in 2246 let x0 = Dot x0 x2 in 2247 let x2 = x0 in 2248 let x0 = Sym "NIL" in 2249 (x0,x1,x2,x3,x4,x5,xs) 2250 else 2251 let xs = x5::xs in 2252 let xs = x4::xs in 2253 let xs = x3::xs in 2254 let xs = x1::xs in 2255 let x5 = x0 in 2256 (* sexp_lets list2sexp [Sym "IF"; CAR (CAR x5); CAR (CDR (CAR x5)); Dot (Sym "COND") (CDR x5)] *) 2257 let x3 = Sym "NIL" in 2258 let x1 = SAFE_CDR x5 in 2259 let x0 = Sym "COND" in 2260 let x2 = x0 in 2261 let x0 = x2 in 2262 let x0 = Dot x0 x1 in 2263 let x2 = x0 in 2264 let x0 = x2 in 2265 let x0 = Dot x0 x3 in 2266 let x1 = x0 in 2267 let x2 = SAFE_CAR x5 in 2268 let x2 = SAFE_CDR x2 in 2269 let x2 = SAFE_CAR x2 in 2270 let x0 = x2 in 2271 let x0 = Dot x0 x1 in 2272 let x1 = x0 in 2273 let x2 = SAFE_CAR x5 in 2274 let x2 = SAFE_CAR x2 in 2275 let x0 = x2 in 2276 let x0 = Dot x0 x1 in 2277 let x1 = x0 in 2278 let x0 = Sym "IF" in 2279 let x2 = x0 in 2280 let x0 = x2 in 2281 let x0 = Dot x0 x1 in 2282 let x2 = x0 in 2283 let x1 = HD xs in 2284 let xs = TL xs in 2285 let x3 = HD xs in 2286 let xs = TL xs in 2287 let x4 = HD xs in 2288 let xs = TL xs in 2289 let x5 = HD xs in 2290 let xs = TL xs in 2291 let x0 = Sym "NIL" in 2292 (x0,x1,x2,x3,x4,x5,xs)) else 2293 if x0 = Sym "AND" then 2294 let x0 = SAFE_CDR x2 in 2295 (if x0 = Sym "NIL" then 2296 let x2 = Sym "T" in 2297 let x0 = Sym "NIL" in 2298 let x2 = Dot x2 x0 in 2299 let x0 = Sym "QUOTE" in 2300 let x0 = Dot x0 x2 in 2301 let x2 = x0 in 2302 let x0 = Sym "NIL" in 2303 (x0,x1,x2,x3,x4,x5,xs) 2304 else 2305 let xs = x5::xs in 2306 let xs = x4::xs in 2307 let xs = x3::xs in 2308 let xs = x1::xs in 2309 let x5 = x0 in 2310 let x4 = SAFE_CDR x5 in 2311 if isDot x4 then 2312 (* sexp_lets list2sexp [Sym "IF"; (SAFE_CAR x5); Dot (Sym "AND") (SAFE_CDR x5); list2sexp [Sym "QUOTE"; list2sexp []]] *) 2313 let x3 = Sym "NIL" in 2314 let x1 = Sym "NIL" in 2315 let x2 = Sym "NIL" in 2316 let x0 = x2 in 2317 let x0 = Dot x0 x1 in 2318 let x1 = x0 in 2319 let x0 = Sym "QUOTE" in 2320 let x2 = x0 in 2321 let x0 = x2 in 2322 let x0 = Dot x0 x1 in 2323 let x2 = x0 in 2324 let x0 = x2 in 2325 let x0 = Dot x0 x3 in 2326 let x3 = x0 in 2327 let x1 = SAFE_CDR x5 in 2328 let x0 = Sym "AND" in 2329 let x2 = x0 in 2330 let x0 = x2 in 2331 let x0 = Dot x0 x1 in 2332 let x2 = x0 in 2333 let x0 = x2 in 2334 let x0 = Dot x0 x3 in 2335 let x1 = x0 in 2336 let x2 = SAFE_CAR x5 in 2337 let x0 = x2 in 2338 let x0 = Dot x0 x1 in 2339 let x1 = x0 in 2340 let x0 = Sym "IF" in 2341 let x2 = x0 in 2342 let x0 = x2 in 2343 let x0 = Dot x0 x1 in 2344 let x2 = x0 in 2345 let x1 = HD xs in 2346 let xs = TL xs in 2347 let x3 = HD xs in 2348 let xs = TL xs in 2349 let x4 = HD xs in 2350 let xs = TL xs in 2351 let x5 = HD xs in 2352 let xs = TL xs in 2353 let x0 = Sym "NIL" in 2354 (x0,x1,x2,x3,x4,x5,xs) 2355 else 2356 let x2 = SAFE_CAR x0 in 2357 let x1 = HD xs in 2358 let xs = TL xs in 2359 let x3 = HD xs in 2360 let xs = TL xs in 2361 let x4 = HD xs in 2362 let xs = TL xs in 2363 let x5 = HD xs in 2364 let xs = TL xs in 2365 let x0 = Sym "NIL" in 2366 (x0,x1,x2,x3,x4,x5,xs)) else 2367 if x0 = Sym "LIST" then 2368 let x0 = SAFE_CDR x2 in 2369 (if x0 = Sym "NIL" then 2370 let x0 = Sym "NIL" in 2371 let x2 = Sym "NIL" in 2372 let x2 = Dot x2 x0 in 2373 let x0 = Sym "QUOTE" in 2374 let x0 = Dot x0 x2 in 2375 let x2 = x0 in 2376 let x0 = Sym "NIL" in 2377 (x0,x1,x2,x3,x4,x5,xs) 2378 else 2379 let xs = x5::xs in 2380 let xs = x4::xs in 2381 let xs = x3::xs in 2382 let xs = x1::xs in 2383 let x5 = x0 in 2384 (* let x2 = list2sexp [Sym "CONS"; (SAFE_CAR x5); Dot (Sym "LIST") (SAFE_CDR x5)] in *) 2385 let x3 = Sym "NIL" in 2386 let x1 = SAFE_CDR x5 in 2387 let x0 = Sym "LIST" in 2388 let x2 = x0 in 2389 let x2 = Dot x2 x1 in 2390 let x1 = x2 in 2391 let x1 = Dot x1 x3 in 2392 let x2 = SAFE_CAR x5 in 2393 let x0 = x2 in 2394 let x0 = Dot x0 x1 in 2395 let x1 = x0 in 2396 let x0 = Sym "CONS" in 2397 let x2 = x0 in 2398 let x2 = Dot x2 x1 in 2399 let x1 = HD xs in 2400 let xs = TL xs in 2401 let x3 = HD xs in 2402 let xs = TL xs in 2403 let x4 = HD xs in 2404 let xs = TL xs in 2405 let x5 = HD xs in 2406 let xs = TL xs in 2407 let x0 = Sym "NIL" in 2408 (x0,x1,x2,x3,x4,x5,xs)) else 2409 if x0 = Sym "DEFUN" then 2410 (let xs = x5::xs in 2411 let xs = x4::xs in 2412 let xs = x3::xs in 2413 let xs = x1::xs in 2414 let x5 = x2 in 2415 let x3 = Sym "NIL" in 2416 let x2 = Sym "NIL" in 2417 let x0 = SAFE_CDR x5 in 2418 let x0 = SAFE_CDR x0 in 2419 let x0 = SAFE_CDR x0 in 2420 let x0 = SAFE_CAR x0 in 2421 let x0 = Dot x0 x2 in 2422 let x1 = x0 in 2423 let x0 = Sym "QUOTE" in 2424 let x2 = x0 in 2425 let x0 = x2 in 2426 let x0 = Dot x0 x1 in 2427 let x2 = x0 in 2428 let x0 = x2 in 2429 let x0 = Dot x0 x3 in 2430 let x3 = x0 in 2431 let x2 = Sym "NIL" in 2432 let x0 = SAFE_CDR x5 in 2433 let x0 = SAFE_CDR x0 in 2434 let x0 = SAFE_CAR x0 in 2435 let x0 = Dot x0 x2 in 2436 let x1 = x0 in 2437 let x0 = Sym "QUOTE" in 2438 let x2 = x0 in 2439 let x0 = x2 in 2440 let x0 = Dot x0 x1 in 2441 let x2 = x0 in 2442 let x0 = x2 in 2443 let x0 = Dot x0 x3 in 2444 let x3 = x0 in 2445 let x2 = Sym "NIL" in 2446 let x0 = SAFE_CDR x5 in 2447 let x0 = SAFE_CAR x0 in 2448 let x0 = Dot x0 x2 in 2449 let x1 = x0 in 2450 let x0 = Sym "QUOTE" in 2451 let x2 = x0 in 2452 let x0 = x2 in 2453 let x0 = Dot x0 x1 in 2454 let x2 = x0 in 2455 let x0 = x2 in 2456 let x0 = Dot x0 x3 in 2457 let x1 = x0 in 2458 let x0 = Sym "DEFINE" in 2459 let x2 = x0 in 2460 let x0 = x2 in 2461 let x0 = Dot x0 x1 in 2462 let x2 = x0 in 2463 let x1 = HD xs in 2464 let xs = TL xs in 2465 let x3 = HD xs in 2466 let xs = TL xs in 2467 let x4 = HD xs in 2468 let xs = TL xs in 2469 let x5 = HD xs in 2470 let xs = TL xs in 2471 let x0 = Sym "NIL" in 2472 (x0,x1,x2,x3,x4,x5,xs)) else 2473 let x0 = Sym "NIL" in 2474 (x0,x1,x2,x3,x4,x5,xs)``; 2475 2476val mc_expand_macro_thm = prove( 2477 ``(mc_expand_macro = BC_expand_macro) /\ !x. mc_expand_macro_pre x``, 2478 STRIP_TAC THEN1 2479 (SIMP_TAC std_ss [FUN_EQ_THM,FORALL_PROD,BC_expand_macro_def, 2480 mc_expand_macro_def,LET_DEF,HD,TL,list2sexp_def,SAFE_CAR_def,SAFE_CDR_def] 2481 \\ SRW_TAC [] []) 2482 \\ FULL_SIMP_TAC std_ss [FORALL_PROD,mc_expand_macro_pre_def, 2483 LET_DEF,HD,TL,NOT_CONS_NIL,mc_map_car_alternative_thm]); 2484 2485(* BC_aux_ev is a readable version of mc_aux_ev *) 2486val BC_aux_ev_def = Define ` 2487 BC_aux_ev (temp:SExp,task,exp,a,ret,consts:SExp,xs,xs1,code) = 2488 if isSym exp then 2489 (let (t1,loc,t2,t3) = mc_alist_lookup (task,Val 0,exp,a) in 2490 if loc = Sym "NIL" then 2491 let code = WRITE_CODE code [iFAIL] in 2492 let task = ^CONTINUE in 2493 let a = Dot (Val 0) a in 2494 let (t1,t2,a,ret,code) = mc_return_code (task,task,a,ret,code) in 2495 (Sym "NIL",task,exp,a,ret,consts,xs,xs1,code) 2496 else 2497 let code = WRITE_CODE code [iLOAD (getVal loc)] in 2498 let task = ^CONTINUE in 2499 let a = Dot (Val 0) a in 2500 let (t1,t2,a,ret,code) = mc_return_code (task,task,a,ret,code) in 2501 (Sym "NIL",task,exp,a,ret,consts,xs,xs1,code)) 2502 else if CAR exp = Sym "IF" then 2503 let temp = ret in 2504 let xs = CAR exp::Dot a (CDR (CDR exp))::temp::xs in (* put if on todo list *) 2505 let exp = CAR (CDR exp) in 2506 let ret = Sym "NIL" in 2507 (Sym "NIL",task,exp,a,ret,consts,xs,xs1,code) 2508 else if CAR exp = Sym "OR" then 2509 if ~(isDot (CDR exp)) then 2510 let exp = Sym "NIL" in 2511 let code = WRITE_CODE code [iCONST_SYM (getSym exp)] in 2512 let task = ^CONTINUE in 2513 let a = Dot (Val 0) a in 2514 let (t1,t2,a,ret,code) = mc_return_code (task,task,a,ret,code) in 2515 (Sym "NIL",task,exp,a,ret,consts,xs,xs1,code) 2516 else 2517 let temp = ret in 2518 let xs = CAR exp::Dot a (CDR (CDR exp))::temp::xs in (* put if on todo list *) 2519 let exp = CAR (CDR exp) in 2520 let ret = Sym "NIL" in 2521 (Sym "NIL",task,exp,a,ret,consts,xs,xs1,code) 2522 else if isQuote exp then 2523 let exp = CAR (CDR exp) in 2524 if isVal exp then 2525 let code = WRITE_CODE code [iCONST_NUM (getVal exp)] in 2526 let task = ^CONTINUE in 2527 let a = Dot (Val 0) a in 2528 let (t1,t2,a,ret,code) = mc_return_code (task,task,a,ret,code) in 2529 (Sym "NIL",task,exp,a,ret,consts,xs,xs1,code) 2530 else if isSym exp then 2531 let code = WRITE_CODE code [iCONST_SYM (getSym exp)] in 2532 let task = ^CONTINUE in 2533 let a = Dot (Val 0) a in 2534 let (t1,t2,a,ret,code) = mc_return_code (task,task,a,ret,code) in 2535 (Sym "NIL",task,exp,a,ret,consts,xs,xs1,code) 2536 else 2537 let (task,xs1) = (Val (LENGTH xs1),xs1 ++ [exp]) in 2538 let code = WRITE_CODE code [iCONST_NUM (getVal task)] in 2539 let code = WRITE_CODE code [iCONST_LOOKUP] in 2540 let task = ^CONTINUE in 2541 let a = Dot (Val 0) a in 2542 let (t1,t2,a,ret,code) = mc_return_code (task,task,a,ret,code) in 2543 (Sym "NIL",task,exp,a,ret,consts,xs,xs1,code) 2544 else if isDot (CAR exp) then (* lambda *) 2545 let temp = ret in 2546 let xs = ^COMPILE_LAM1::exp::temp::a::xs in 2547 let exp = CDR exp in 2548 let ret = Sym "NIL" in 2549 let task = ^COMPILE_EVL in 2550 (Sym "NIL",task,exp,a,ret,consts,xs,xs1,code) 2551 else if isVal exp then 2552 let exp = Dot (Sym "QUOTE") (Dot exp (Sym "NIL")) in 2553 (Sym "NIL",task,exp,a,ret,consts,xs,xs1,code) 2554 else (* function application or macro *) 2555 let temp = exp in 2556 let exp = CAR exp in 2557 let exp = BC_is_reserved_name exp in 2558 if exp = Sym "NIL" then (* user-defined function *) 2559 (let (t1,temp) = mc_strip_app (ret,temp) in 2560 if ret = Sym "NIL" then 2561 let xs = ^COMPILE_CALL::temp::xs in 2562 let ret = Sym "NIL" in 2563 let exp = CDR temp in 2564 let task = ^COMPILE_EVL in 2565 (Sym "NIL",task,exp,a,ret,consts,xs,xs1,code) 2566 else (* tail-optimisation *) 2567 let (t1,al) = mc_length (a,Val 0) in 2568 let (t1,xl) = mc_length (CDR temp,Val 0) in 2569 let padding = LISP_SUB xl al in 2570 let (t1,t2,a,code) = mc_push_nils (Sym "NIL",padding,a,code) in 2571 let xs = ^COMPILE_TAILOPT::Dot al xl::^COMPILE_SET_RET::ret::^COMPILE_CALL::temp::xs in 2572 let ret = Sym "NIL" in 2573 let exp = CDR temp in 2574 let task = ^COMPILE_EVL in 2575 (Sym "NIL",task,exp,a,ret,consts,xs,xs1,code)) 2576 else 2577 (if exp = Val 0 then (* macro *) 2578 let exp = temp in 2579 let task = ^COMPILE_MACRO in 2580 (Sym "NIL",task,exp,a,ret,consts,xs,xs1,code) 2581 else 2582 (* built-in function *) 2583 let exp = temp in 2584 let temp = CDR temp in 2585 let (t1,temp) = mc_length (temp,Val 0) in 2586 let temp = Dot (CAR exp) temp in 2587 let xs = ^COMPILE_SET_RET::ret::^COMPILE_AP::temp::xs in 2588 let ret = Sym "NIL" in 2589 let exp = CDR exp in 2590 let task = ^COMPILE_EVL in 2591 (Sym "NIL",task,exp,a,ret,consts,xs,xs1,code))`; 2592 2593(* val mc_aux_ev_def = Define *) 2594val (thm,mc_aux_ev_def,mc_aux_ev_pre_def) = compile "x64" `` 2595 mc_aux_ev (x0:SExp,x1,x2,x3,x4,x5:SExp,xs,xs1,code) = 2596 if isSym x2 then 2597 (let x0 = x1 in 2598 let x1 = Val 0 in 2599 let xs = x2::xs in 2600 let xs = x3::xs in 2601 let (x0,x1,x2,x3) = mc_alist_lookup (x0,x1,x2,x3) in 2602 let x3 = HD xs in 2603 let xs = TL xs in 2604 let x2 = HD xs in 2605 let xs = TL xs in 2606 let x0 = Val 0 in 2607 let x0 = Dot x0 x3 in 2608 let x3 = x0 in 2609 if x1 = Sym "NIL" then 2610 let code = WRITE_CODE code [iFAIL] in 2611 let x0 = ^CONTINUE in 2612 let x1 = ^CONTINUE in 2613 let (x0,x1,x3,x4,code) = mc_return_code (x0,x1,x3,x4,code) in 2614 let x1 = ^CONTINUE in 2615 let x0 = Sym "NIL" in 2616 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 2617 else 2618 let x0 = x1 in 2619 let code = WRITE_CODE code [iLOAD (getVal x0)] in 2620 let x0 = ^CONTINUE in 2621 let x1 = ^CONTINUE in 2622 let (x0,x1,x3,x4,code) = mc_return_code (x0,x1,x3,x4,code) in 2623 let x1 = ^CONTINUE in 2624 let x0 = Sym "NIL" in 2625 (x0,x1,x2,x3,x4,x5,xs,xs1,code)) 2626(* 2627 else let x0 = SAFE_CAR x2 in if x0 = Val 1 then 2628 (let x2 = SAFE_CDR x2 in 2629 let x0 = x1 in 2630 let x1 = Val 0 in 2631 let xs = x2::xs in 2632 let xs = x3::xs in 2633 let (x0,x1,x2,x3) = mc_alist_lookup (x0,x1,x2,x3) in 2634 let x3 = HD xs in 2635 let xs = TL xs in 2636 let x2 = HD xs in 2637 let xs = TL xs in 2638 let x0 = Val 0 in 2639 let x0 = Dot x0 x3 in 2640 let x3 = x0 in 2641 if x1 = Sym "NIL" then 2642 let code = WRITE_CODE code [iFAIL] in 2643 let x0 = ^CONTINUE in 2644 let x1 = ^CONTINUE in 2645 let (x0,x1,x3,x4,code) = mc_return_code (x0,x1,x3,x4,code) in 2646 let x1 = ^CONTINUE in 2647 let x0 = Sym "NIL" in 2648 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 2649 else 2650 let x0 = x1 in 2651 let code = WRITE_CODE code [iLOAD (getVal x0)] in 2652 let x0 = ^CONTINUE in 2653 let x1 = ^CONTINUE in 2654 let (x0,x1,x3,x4,code) = mc_return_code (x0,x1,x3,x4,code) in 2655 let x1 = ^CONTINUE in 2656 let x0 = Sym "NIL" in 2657 (x0,x1,x2,x3,x4,x5,xs,xs1,code)) 2658*) 2659 else let x0 = SAFE_CAR x2 in if x0 = Sym "IF" then (* put if on todo list *) 2660 let xs = x4::xs in 2661 let x4 = SAFE_CDR x2 in 2662 let x4 = SAFE_CDR x4 in 2663 let x0 = x3 in 2664 let x0 = Dot x0 x4 in 2665 let xs = x0::xs in 2666 let x0 = SAFE_CAR x2 in 2667 let xs = x0::xs in 2668 let x2 = SAFE_CDR x2 in 2669 let x2 = SAFE_CAR x2 in 2670 let x4 = Sym "NIL" in 2671 let x0 = Sym "NIL" in 2672 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 2673 else let x0 = SAFE_CAR x2 in if x0 = Sym "OR" then 2674 let x0 = SAFE_CDR x2 in if ~(isDot x0) then 2675 let x0 = Sym "NIL" in 2676 let code = WRITE_CODE code [iCONST_SYM (getSym x0)] in 2677 let x0 = x3 in 2678 let x3 = Val 0 in 2679 let x3 = Dot x3 x0 in 2680 let x0 = ^CONTINUE in 2681 let x1 = ^CONTINUE in 2682 let (x0,x1,x3,x4,code) = mc_return_code (x0,x1,x3,x4,code) in 2683 let x0 = Sym "NIL" in 2684 let x1 = ^CONTINUE in 2685 let x2 = Sym "NIL" in 2686 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 2687 else 2688 let xs = x4::xs in 2689 let x0 = SAFE_CDR x2 in 2690 let x0 = SAFE_CDR x0 in 2691 let x4 = x3 in 2692 let x4 = Dot x4 x0 in 2693 let xs = x4::xs in 2694 let x0 = SAFE_CAR x2 in 2695 let xs = x0::xs in 2696 let x2 = SAFE_CDR x2 in 2697 let x2 = SAFE_CAR x2 in 2698 let x0 = Sym "NIL" in 2699 let x4 = Sym "NIL" in 2700 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 2701 else let x0 = x2 in let x0 = LISP_TEST (isQuote x0) in if x0 = Sym "T" then 2702 let x2 = SAFE_CDR x2 in 2703 let x2 = SAFE_CAR x2 in 2704 if isVal x2 then 2705 let x0 = x2 in 2706 let code = WRITE_CODE code [iCONST_NUM (getVal x0)] in 2707 let x0 = Val 0 in 2708 let x0 = Dot x0 x3 in 2709 let x3 = x0 in 2710 let x0 = ^CONTINUE in 2711 let x1 = ^CONTINUE in 2712 let (x0,x1,x3,x4,code) = mc_return_code (x0,x1,x3,x4,code) in 2713 let x1 = ^CONTINUE in 2714 let x0 = Sym "NIL" in 2715 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 2716 else if isSym x2 then 2717 let x0 = x2 in 2718 let code = WRITE_CODE code [iCONST_SYM (getSym x0)] in 2719 let x0 = Val 0 in 2720 let x0 = Dot x0 x3 in 2721 let x3 = x0 in 2722 let x0 = ^CONTINUE in 2723 let x1 = ^CONTINUE in 2724 let (x0,x1,x3,x4,code) = mc_return_code (x0,x1,x3,x4,code) in 2725 let x1 = ^CONTINUE in 2726 let x0 = Sym "NIL" in 2727 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 2728 else 2729 let x0 = x2 in 2730 let (x0,xs1) = (Val (LENGTH xs1),xs1 ++ [x0]) in 2731 let code = WRITE_CODE code [iCONST_NUM (getVal x0)] in 2732 let code = WRITE_CODE code [iCONST_LOOKUP] in 2733 let x0 = Val 0 in 2734 let x0 = Dot x0 x3 in 2735 let x3 = x0 in 2736 let x0 = ^CONTINUE in 2737 let x1 = ^CONTINUE in 2738 let (x0,x1,x3,x4,code) = mc_return_code (x0,x1,x3,x4,code) in 2739 let x1 = ^CONTINUE in 2740 let x0 = Sym "NIL" in 2741 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 2742 else let x0 = SAFE_CAR x2 in if isDot x0 then (* lambda *) 2743 let x0 = x4 in 2744 let xs = x3::xs in 2745 let xs = x0::xs in 2746 let xs = x2::xs in 2747 let x0 = ^COMPILE_LAM1 in 2748 let xs = x0::xs in 2749 let x2 = SAFE_CDR x2 in 2750 let x4 = Sym "NIL" in 2751 let x1 = ^COMPILE_EVL in 2752 let x0 = Sym "NIL" in 2753 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 2754 else if isVal x2 then 2755 let x0 = Sym "NIL" in 2756 let x2 = Dot x2 x0 in 2757 let x0 = Sym "QUOTE" in 2758 let x0 = Dot x0 x2 in 2759 let x2 = x0 in 2760 let x0 = Sym "NIL" in 2761 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 2762 else (* function application or macro *) 2763 let x0 = SAFE_CAR x2 in 2764 let x0 = mc_is_reserved_name x0 in 2765 if x0 = Sym "NIL" then (* user-defined function *) 2766 (let x0 = x4 in 2767 let x1 = x2 in 2768 let (x0,x1) = mc_strip_app (x0,x1) in 2769 let x0 = x1 in 2770 if x4 = Sym "NIL" then 2771 let xs = x0::xs in 2772 let x0 = ^COMPILE_CALL in 2773 let xs = x0::xs in 2774 let x4 = Sym "NIL" in 2775 let x2 = SAFE_CDR x1 in 2776 let x1 = ^COMPILE_EVL in 2777 let x0 = Sym "NIL" in 2778 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 2779 else (* tail-optimisation *) 2780 let xs = x0::xs in 2781 let x1 = ^COMPILE_CALL in 2782 let xs = x1::xs in 2783 let xs = x4::xs in 2784 let x1 = ^COMPILE_SET_RET in 2785 let xs = x1::xs in 2786 let xs = x0::xs in 2787 let x0 = x3 in 2788 let x1 = Val 0 in 2789 let (x0,x1) = mc_length (x0,x1) in 2790 let x0 = HD xs in 2791 let xs = x1::xs in 2792 let x0 = SAFE_CDR x0 in 2793 let x1 = Val 0 in 2794 let (x0,x1) = mc_length (x0,x1) in 2795 let x4 = HD xs in 2796 let xs = TL xs in 2797 let x0 = HD xs in 2798 let xs = TL xs in 2799 let x4 = Dot x4 x1 in 2800 let xs = x4::xs in 2801 let x2 = x0 in 2802 let x0 = ^COMPILE_TAILOPT in 2803 let xs = x0::xs in 2804 let x4 = SAFE_CAR x4 in 2805 let x0 = x1 in 2806 let x1 = x4 in 2807 let x0 = LISP_SUB x0 x1 in 2808 let x1 = x0 in 2809 let x0 = Sym "NIL" in 2810 let (x0,x1,x3,code) = mc_push_nils (x0,x1,x3,code) in 2811 let x4 = Sym "NIL" in 2812 let x2 = SAFE_CDR x2 in 2813 let x1 = ^COMPILE_EVL in 2814 let x0 = Sym "NIL" in 2815 (x0,x1,x2,x3,x4,x5,xs,xs1,code)) 2816 else 2817 (if x0 = Val 0 then (* macro *) 2818 let x0 = ^COMPILE_MACRO in 2819 let x1 = x0 in 2820 let x0 = Sym "NIL" in 2821 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 2822 else 2823 (* built-in function *) 2824 let x0 = SAFE_CDR x2 in 2825 let x1 = Val 0 in 2826 let (x0,x1) = mc_length (x0,x1) in 2827 let x0 = x1 in 2828 let x1 = SAFE_CAR x2 in 2829 let x1 = Dot x1 x0 in 2830 let xs = x1::xs in 2831 let x0 = ^COMPILE_AP in 2832 let xs = x0::xs in 2833 let xs = x4::xs in 2834 let x0 = ^COMPILE_SET_RET in 2835 let xs = x0::xs in 2836 let x4 = Sym "NIL" in 2837 let x2 = SAFE_CDR x2 in 2838 let x1 = ^COMPILE_EVL in 2839 let x0 = Sym "NIL" in 2840 (x0,x1,x2,x3,x4,x5,xs,xs1,code))``; 2841 2842val LISP_TEST_EQ_T = prove(``!b. (LISP_TEST b = Sym "T") = b``, Cases \\ EVAL_TAC); 2843 2844val mc_aux_ev_thm = prove( 2845 ``mc_aux_ev = BC_aux_ev``, 2846 SIMP_TAC std_ss [FUN_EQ_THM,FORALL_PROD,BC_aux_ev_def,LISP_TEST_EQ_T,CAR_def, 2847 mc_aux_ev_def,LET_DEF,HD,TL,list2sexp_def,mc_is_reserved_name_thm,CDR_def, 2848 SAFE_CAR_def,SAFE_CDR_def] \\ SRW_TAC [] []); 2849 2850 2851val BC_aux_ap_def = Define ` 2852 BC_aux_ap (temp:SExp,task:SExp,exp,a,ret,xs:SExp list,code) = 2853 if CAR exp = Sym "DEFINE" then 2854 let code = WRITE_CODE code [iCOMPILE] in 2855 let task = ^CONTINUE in 2856 let (temp,a) = mc_drop (CDR exp,a) in 2857 let a = Dot (Val 0) a in 2858 let (t1,t2,a,ret,code) = mc_return_code (task,task,a,ret,code) in 2859 (Sym "NIL", task,exp,a,ret,xs,code) 2860 else if CAR exp = Sym "PRINT" then 2861 let code = WRITE_CODE code [iCONST_SYM "NIL"] in 2862 let (t1,code) = mc_cons_list (CDR exp,code) in 2863 let code = WRITE_CODE code [iCONST_SYM "PRINT"] in 2864 let code = WRITE_CODE code [iLOAD 1] in 2865 let code = WRITE_CODE code [iDATA opCONS] in 2866 let code = WRITE_CODE code [iPRINT] in 2867 let code = WRITE_CODE code [iCONST_SYM "NIL"] in 2868 let code = WRITE_CODE code [iPOPS 2] in 2869 let task = ^CONTINUE in 2870 let (temp,a) = mc_drop (CDR exp,a) in 2871 let a = Dot (Val 0) a in 2872 let (t1,t2,a,ret,code) = mc_return_code (task,task,a,ret,code) in 2873 (Sym "NIL", task,exp,a,ret,xs,code) 2874 else if CAR exp = Sym "ERROR" then 2875 let code = WRITE_CODE code [iCONST_SYM "NIL"] in 2876 let (t1,code) = mc_cons_list (CDR exp,code) in 2877 let code = WRITE_CODE code [iCONST_SYM "ERROR"] in 2878 let code = WRITE_CODE code [iLOAD 1] in 2879 let code = WRITE_CODE code [iDATA opCONS] in 2880 let code = WRITE_CODE code [iPRINT] in 2881 let code = WRITE_CODE code [iFAIL] in 2882 let task = ^CONTINUE in 2883 let (temp,a) = mc_drop (CDR exp,a) in 2884 let a = Dot (Val 0) a in 2885 let (t1,t2,a,ret,code) = mc_return_code (task,task,a,ret,code) in 2886 (Sym "NIL", task,exp,a,ret,xs,code) 2887 else if CAR exp = Sym "FUNCALL" then 2888 let task = LISP_SUB (CDR exp) (Val 1) in 2889 let code = WRITE_CODE code [iCONST_NUM (getVal task)] in 2890 let code = WRITE_CODE code [iLOAD (getVal (CDR exp))] in 2891 let code = WRITE_CODE code [iCALL_SYM] in 2892 let code = WRITE_CODE code [iPOPS 1] in 2893 let task = ^CONTINUE in 2894 let (temp,a) = mc_drop (CDR exp,a) in 2895 let a = Dot (Val 0) a in 2896 let (t1,t2,a,ret,code) = mc_return_code (task,task,a,ret,code) in 2897 (Sym "NIL", task,exp,a,ret,xs,code) 2898 else (* primitive function *) 2899 let (task,temp,code) = mc_primitive (CAR exp,CDR exp,code) in 2900 let task = ^CONTINUE in 2901 let (temp,a) = mc_drop (CDR exp,a) in 2902 let a = Dot (Val 0) a in 2903 let (t1,t2,a,ret,code) = mc_return_code (task,task,a,ret,code) in 2904 (Sym "NIL", task,exp,a,ret,xs,code)`; 2905 2906(* val mc_aux_ap_def = Define *) 2907val (_,mc_aux_ap_def,mc_aux_ap_pre_def) = compile "x64" `` 2908 mc_aux_ap (x0:SExp,x1:SExp,x2:SExp,x3:SExp,x4:SExp,xs:SExp list,code) = 2909 let x0 = SAFE_CAR x2 in 2910 if x0 = Sym "DEFINE" then 2911 let code = WRITE_CODE code [iCOMPILE] in 2912 let x1 = ^CONTINUE in 2913 let x0 = SAFE_CDR x2 in 2914 let (x0,x3) = mc_drop (x0,x3) in 2915 let x0 = Val 0 in 2916 let x0 = Dot x0 x3 in 2917 let x3 = x0 in 2918 let x0 = ^CONTINUE in 2919 let x1 = ^CONTINUE in 2920 let (x0,x1,x3,x4,code) = mc_return_code (x0,x1,x3,x4,code) in 2921 let x1 = ^CONTINUE in 2922 let x0 = Sym "NIL" in 2923 (x0,x1,x2,x3,x4,xs,code) 2924 else if x0 = Sym "PRINT" then 2925 let x0 = Sym "NIL" in 2926 let code = WRITE_CODE code [iCONST_SYM (getSym x0)] in 2927 let x0 = x1 in 2928 let x1 = SAFE_CDR x2 in 2929 let (x1,code) = mc_cons_list (x1,code) in 2930 let x0 = Sym "PRINT" in 2931 let code = WRITE_CODE code [iCONST_SYM (getSym x0)] in 2932 let x0 = Val 1 in 2933 let code = WRITE_CODE code [iLOAD (getVal x0)] in 2934 let code = WRITE_CODE code [iDATA opCONS] in 2935 let code = WRITE_CODE code [iPRINT] in 2936 let x0 = Sym "NIL" in 2937 let code = WRITE_CODE code [iCONST_SYM (getSym x0)] in 2938 let x0 = Val 1 in 2939 let x0 = LISP_ADD x0 (Val 1) in 2940 let code = WRITE_CODE code [iPOPS (getVal x0)] in 2941 let x0 = SAFE_CDR x2 in 2942 let (x0,x3) = mc_drop (x0,x3) in 2943 let x0 = Val 0 in 2944 let x0 = Dot x0 x3 in 2945 let x3 = x0 in 2946 let x0 = ^CONTINUE in 2947 let x1 = ^CONTINUE in 2948 let (x0,x1,x3,x4,code) = mc_return_code (x0,x1,x3,x4,code) in 2949 let x1 = ^CONTINUE in 2950 let x0 = Sym "NIL" in 2951 (x0,x1,x2,x3,x4,xs,code) 2952 else if x0 = Sym "ERROR" then 2953 let x0 = Sym "NIL" in 2954 let code = WRITE_CODE code [iCONST_SYM (getSym x0)] in 2955 let x0 = x1 in 2956 let x1 = SAFE_CDR x2 in 2957 let (x1,code) = mc_cons_list (x1,code) in 2958 let x0 = Sym "ERROR" in 2959 let code = WRITE_CODE code [iCONST_SYM (getSym x0)] in 2960 let x0 = Val 1 in 2961 let code = WRITE_CODE code [iLOAD (getVal x0)] in 2962 let code = WRITE_CODE code [iDATA opCONS] in 2963 let code = WRITE_CODE code [iPRINT] in 2964 let code = WRITE_CODE code [iFAIL] in 2965 let x0 = SAFE_CDR x2 in 2966 let (x0,x3) = mc_drop (x0,x3) in 2967 let x0 = Val 0 in 2968 let x0 = Dot x0 x3 in 2969 let x3 = x0 in 2970 let x0 = ^CONTINUE in 2971 let x1 = ^CONTINUE in 2972 let (x0,x1,x3,x4,code) = mc_return_code (x0,x1,x3,x4,code) in 2973 let x1 = ^CONTINUE in 2974 let x0 = Sym "NIL" in 2975 (x0,x1,x2,x3,x4,xs,code) 2976 else if x0 = Sym "FUNCALL" then 2977 let x0 = SAFE_CDR x2 in 2978 let x1 = Val 1 in 2979 let x0 = LISP_SUB x0 x1 in 2980 let code = WRITE_CODE code [iCONST_NUM (getVal x0)] in 2981 let x0 = SAFE_CDR x2 in 2982 let code = WRITE_CODE code [iLOAD (getVal x0)] in 2983 let code = WRITE_CODE code [iCALL_SYM] in 2984 let x0 = Val 1 in 2985 let code = WRITE_CODE code [iPOPS (getVal x0)] in 2986 let x0 = SAFE_CDR x2 in 2987 let (x0,x3) = mc_drop (x0,x3) in 2988 let x0 = Val 0 in 2989 let x0 = Dot x0 x3 in 2990 let x3 = x0 in 2991 let x0 = ^CONTINUE in 2992 let x1 = ^CONTINUE in 2993 let (x0,x1,x3,x4,code) = mc_return_code (x0,x1,x3,x4,code) in 2994 let x1 = ^CONTINUE in 2995 let x0 = Sym "NIL" in 2996 (x0,x1,x2,x3,x4,xs,code) 2997 else (* primitive function *) 2998 let x0 = SAFE_CAR x2 in 2999 let x1 = SAFE_CDR x2 in 3000 let (x0,x1,code) = mc_primitive (x0,x1,code) in 3001 let x0 = SAFE_CDR x2 in 3002 let (x0,x3) = mc_drop (x0,x3) in 3003 let x0 = Val 0 in 3004 let x0 = Dot x0 x3 in 3005 let x3 = x0 in 3006 let x0 = ^CONTINUE in 3007 let x1 = ^CONTINUE in 3008 let (x0,x1,x3,x4,code) = mc_return_code (x0,x1,x3,x4,code) in 3009 let x1 = ^CONTINUE in 3010 let x0 = Sym "NIL" in 3011 (x0,x1,x2,x3,x4,xs,code)``; 3012 3013val mc_aux_ap_thm = prove( 3014 ``mc_aux_ap = BC_aux_ap``, 3015 SIMP_TAC std_ss [FUN_EQ_THM,FORALL_PROD,BC_aux_ap_def,LISP_TEST_EQ_T,CAR_def,CDR_def, 3016 mc_aux_ap_def,LET_DEF,HD,TL,list2sexp_def,mc_is_reserved_name_thm,getSym_def,getVal_def, 3017 EVAL ``LISP_ADD (Val 1) (Val 1)``,SAFE_CAR_def,SAFE_CDR_def]); 3018 3019 3020val BC_aux_call_aux_def = Define ` 3021 BC_aux_call_aux (temp,ll,a) = 3022 if temp = Sym "NIL" then (temp,ll,a) else 3023 let a = CDR temp in 3024 if a = ll then 3025 let temp = CAR temp in (temp,ll,a) 3026 else 3027 let temp = Sym "NIL" in (temp,ll,a)`; 3028 3029val BC_aux_call_def = Define ` 3030 BC_aux_call (temp:SExp,task:SExp,exp:SExp,a:SExp,ret:SExp,consts:SExp,xs:SExp list,code) = 3031 let (t1,temp,t2) = mc_fun_lookup (task,CDR consts,CAR exp) in 3032 let (t1,ll) = mc_length (CDR exp,Val 0) in 3033 let (t3,a) = mc_drop (ll,a) in 3034 let a = Dot (Val 0) a in 3035 let (temp,ll,a2) = BC_aux_call_aux (temp,ll,a) in 3036 let task = ^CONTINUE in 3037 if temp = Sym "NIL" then 3038 let code = WRITE_CODE code [iCONST_NUM (getVal ll)] in 3039 let code = WRITE_CODE code [iCONST_SYM (getSym (CAR exp))] in 3040 let exp = Sym "NIL" in 3041 if ret = Sym "NIL" then 3042 let code = WRITE_CODE code [iCALL_SYM] in 3043 (Sym "NIL",task,exp,a,ret,consts,xs,code) 3044 else 3045 let a = Sym "NIL" in 3046 let code = WRITE_CODE code [iJUMP_SYM] in 3047 (Sym "NIL",task,exp,a,ret,consts,xs,code) 3048 else 3049 let exp = Sym "NIL" in 3050 if ret = Sym "NIL" then 3051 let code = WRITE_CODE code [iCALL (getVal temp)] in 3052 (Sym "NIL",task,exp,a,ret,consts,xs,code) 3053 else 3054 let a = Sym "NIL" in 3055 let code = WRITE_CODE code [iJUMP (getVal temp)] in 3056 (Sym "NIL",task,exp,a,ret,consts,xs,code)`; 3057 3058val (_,mc_aux_call_aux_def,mc_aux_call_aux_pre_def) = compile "x64" `` 3059 mc_aux_call_aux (x0:SExp,x1:SExp,x3:SExp) = 3060 if x0 = Sym "NIL" then (x0,x1,x3) else 3061 let x3 = CDR x0 in 3062 if x3 = x1 then 3063 let x0 = CAR x0 in (x0,x1,x3) 3064 else 3065 let x0 = Sym "NIL" in (x0,x1,x3)``; 3066 3067(* val mc_aux_call_def = Define *) 3068val (_,mc_aux_call_def,mc_aux_call_pre_def) = compile "x64" `` 3069 mc_aux_call (x0:SExp,x1:SExp,x2:SExp,x3:SExp,x4:SExp,x5:SExp,xs:SExp list,code) = 3070 let xs = x2::xs in 3071 let x0 = x1 in 3072 let x1 = SAFE_CDR x5 in 3073 let x2 = SAFE_CAR x2 in 3074 let (x0,x1,x2) = mc_fun_lookup (x0,x1,x2) in 3075 let x0 = x1 in 3076 let x2 = HD xs in 3077 let xs = TL xs in 3078 let xs = x0::xs in 3079 let x0 = SAFE_CDR x2 in 3080 let x1 = Val 0 in 3081 let (x0,x1) = mc_length (x0,x1) in (* x1 is ll *) 3082 let x0 = x1 in 3083 let x1 = HD xs in 3084 let xs = TL xs in 3085 let xs = x0::xs in 3086 let (x0,x3) = mc_drop (x0,x3) in 3087 let x0 = Val 0 in 3088 let x0 = Dot x0 x3 in 3089 let x3 = x0 in 3090 let x0 = x1 in (* x1 is temp *) 3091 let x1 = HD xs in 3092 let xs = x3::xs in 3093 let (x0,x1,x3) = mc_aux_call_aux (x0,x1,x3) in 3094 let x3 = HD xs in 3095 let xs = TL xs in 3096 let xs = TL xs in 3097 if x0 = Sym "NIL" then 3098 let x0 = x1 in 3099 let code = WRITE_CODE code [iCONST_NUM (getVal x0)] in 3100 let x0 = SAFE_CAR x2 in 3101 let x2 = Sym "NIL" in 3102 let code = WRITE_CODE code [iCONST_SYM (getSym x0)] in 3103 if x4 = Sym "NIL" then 3104 let code = WRITE_CODE code [iCALL_SYM] in 3105 let x1 = ^CONTINUE in 3106 let x0 = Sym "NIL" in 3107 (x0,x1,x2,x3,x4,x5,xs,code) 3108 else 3109 let x3 = Sym "NIL" in 3110 let code = WRITE_CODE code [iJUMP_SYM] in 3111 let x1 = ^CONTINUE in 3112 let x0 = Sym "NIL" in 3113 (x0,x1,x2,x3,x4,x5,xs,code) 3114 else 3115 let x2 = Sym "NIL" in 3116 if x4 = Sym "NIL" then 3117 let code = WRITE_CODE code [iCALL (getVal x0)] in 3118 let x1 = ^CONTINUE in 3119 let x0 = Sym "NIL" in 3120 (x0,x1,x2,x3,x4,x5,xs,code) 3121 else 3122 let x3 = Sym "NIL" in 3123 let code = WRITE_CODE code [iJUMP (getVal x0)] in 3124 let x1 = ^CONTINUE in 3125 let x0 = Sym "NIL" in 3126 (x0,x1,x2,x3,x4,x5,xs,code)`` 3127 3128val mc_aux_call_aux_thm = prove( 3129 ``mc_aux_call_aux = BC_aux_call_aux``, 3130 SIMP_TAC std_ss [FUN_EQ_THM,FORALL_PROD,mc_aux_call_aux_def,BC_aux_call_aux_def]); 3131 3132val mc_aux_call_thm = prove( 3133 ``mc_aux_call = BC_aux_call``, 3134 SIMP_TAC std_ss [FUN_EQ_THM,FORALL_PROD,BC_aux_call_def,CAR_def,CDR_def,mc_aux_call_aux_thm, 3135 mc_aux_call_def,LET_DEF,HD,TL,list2sexp_def,mc_is_reserved_name_thm,getSym_def,getVal_def, 3136 EVAL ``LISP_ADD (Val 1) (Val 1)``,SAFE_CAR_def,SAFE_CDR_def]); 3137 3138 3139(* this is an almost readable version of mc_aux_tail *) 3140val BC_aux_tail_def = Define ` 3141 BC_aux_tail (temp:SExp,task,exp,a,ret,consts,xs,code) = 3142 if task = ^COMPILE_LAM1 then (* ex list has been compiled *) 3143 let ret = HD xs in 3144 let xs = ^COMPILE_LAM2::exp::xs in 3145 let (t1,l) = mc_length (CAR (CDR (CAR exp)),Val 0) in 3146 let (temp,a) = mc_drop (l,a) in 3147 let (t1,t2,a) = mc_rev_append (CAR (CDR (CAR exp)),temp,a) in 3148 let task = ^COMPILE_EV in 3149 let exp = CAR (CDR (CDR (CAR exp))) in 3150 (Sym "NIL",task,exp,a,ret,consts,xs,code) 3151 else if task = ^COMPILE_LAM2 then (* add last append *) 3152 let task = ^CONTINUE in 3153 let temp = HD xs in 3154 let xs = TL xs in 3155 let a = Dot (Val 0) (HD xs) in 3156 let xs = TL xs in 3157 if temp = Sym "T" then 3158 (Sym "NIL",task,exp,a,ret,consts,xs,code) 3159 else 3160 let (t1,l) = mc_length (CAR (CDR (CAR exp)),Val 0) in 3161 let code = WRITE_CODE code [iPOPS (getVal l)] in 3162 (Sym "NIL",task,exp,a,ret,consts,xs,code) 3163 else if task = ^COMPILE_SET_RET then (* assign value to ret *) 3164 let ret = exp in 3165 let task = ^CONTINUE in 3166 (Sym "NIL",task,exp,a,ret,consts,xs,code) 3167 else if task = Sym "IF" then (* guard has been compiled *) 3168 let temp = HD xs in 3169 let ret = temp in 3170 let xs = TL xs in 3171 let task = Val (code_ptr code) in 3172 let xs = task::xs in 3173 let xs = exp::xs in 3174 let exp = Val 0 in 3175 let code = WRITE_CODE code [iJNIL (getVal exp)] in 3176 let exp = HD xs in 3177 let a = CAR exp in 3178 let exp = CDR exp in 3179 let xs = (^COMPILE_IF2)::xs in 3180 let exp = CAR exp in 3181 let task = ^COMPILE_EV in 3182 (Sym "NIL",task,exp,a,ret,consts,xs,code) 3183 else if task = Sym "OR" then (* guard has been compiled *) 3184 let temp = HD xs in 3185 let ret = temp in 3186 let xs = TL xs in 3187 let temp2 = Val 0 in 3188 let code = WRITE_CODE code [iLOAD (getVal temp2)] in 3189 let loc = Val (code_ptr code) in 3190 let exp1 = Val 0 in 3191 let code = WRITE_CODE code [iJNIL (getVal exp1)] in 3192 let a = Dot (Val 0) (CAR exp) in 3193 let (t1,t2,a,ret,code) = mc_return_code (task,task,a,ret,code) in 3194 let task = Val (code_ptr code) in 3195 let xs = task::xs in 3196 let xs = exp::xs in 3197 let exp1 = Val 0 in 3198 let code = WRITE_CODE code [iJUMP (getVal exp1)] in 3199 let task = Val (code_ptr code) in 3200 let code = WRITE_CODE code [iPOP] in 3201 let code = REPLACE_CODE code (getVal loc) (iJNIL (getVal task)) in 3202 let exp = HD xs in 3203 let a = CAR exp in 3204 let exp = CDR exp in 3205 let xs = (^COMPILE_OR2)::xs in 3206 let exp = Dot (Sym "OR") exp in 3207 let task = ^COMPILE_EV in 3208 (Sym "NIL",task,exp,a,ret,consts,xs,code) 3209 else if task = ^COMPILE_IF2 then (* exp for first case has been compiled *) 3210 let task = Val (code_ptr code) in 3211 let temp = HD xs in 3212 let xs = TL xs in 3213 let xs = task::xs in 3214 let xs = exp::xs in 3215 let exp = Val 0 in 3216 let code = WRITE_CODE code [iJUMP (getVal exp)] in 3217 let task = Val (code_ptr code) in 3218 let code = REPLACE_CODE code (getVal temp) (iJNIL (getVal task)) in 3219 let exp = HD xs in 3220 let a = CAR exp in 3221 let xs = a::xs in 3222 let exp = CDR exp in 3223 let xs = TL xs in 3224 let xs = (^COMPILE_IF3)::xs in 3225 let exp = CAR (CDR exp) in 3226 let task = ^COMPILE_EV in 3227 (Sym "NIL",task,exp,a,ret,consts,xs,code) 3228 else if task = ^COMPILE_IF3 then (* exp for fst and snd case have been compiled *) 3229 let a = exp in 3230 let a = CAR a in 3231 let a = Dot (Val 0) a in 3232 let exp = HD xs in 3233 let xs = TL xs in 3234 let task = Val (code_ptr code) in 3235 let code = REPLACE_CODE code (getVal exp) (iJUMP (getVal task)) in 3236 let exp = Sym "NIL" in 3237 let task = ^CONTINUE in 3238 (Sym "NIL",task,exp,a,ret,consts,xs,code) 3239 else if task = ^COMPILE_OR2 then (* just fix the iJUMP *) 3240 let a = exp in 3241 let a = CAR a in 3242 let a = Dot (Val 0) a in 3243 let exp = HD xs in 3244 let xs = TL xs in 3245 let task = Val (code_ptr code) in 3246 let code = REPLACE_CODE code (getVal exp) (iJUMP (getVal task)) in 3247 let exp = Sym "NIL" in 3248 let task = ^CONTINUE in 3249 (Sym "NIL",task,exp,a,ret,consts,xs,code) 3250 else if task = ^COMPILE_TAILOPT then (* rearrange stack for tail call *) 3251 let al = CAR exp in 3252 let xl = CDR exp in 3253 let padding = LISP_SUB xl al in 3254 let (t1,t2,code) = mc_stores (LISP_SUB (LISP_ADD al padding) (Val 1),xl,code) in 3255 let (temp,code) = mc_popn (LISP_SUB al xl,code) in 3256 let task = ^CONTINUE in 3257 (Sym "NIL",task,exp,a,ret,consts,xs,code) 3258 else if task = ^COMPILE_CALL then (* implements BC_call *) 3259 let temp = Sym "NIL" in 3260 let (temp,task,exp,a,ret,consts,xs,code) = BC_aux_call (temp,task,exp,a,ret,consts,xs,code) in 3261 (Sym "NIL",task,exp,a,ret,consts,xs,code) 3262 else (* if task = ^COMPILE_MACRO then ... *) 3263 let temp = Sym "NIL" in 3264 let (temp,task,exp,a,ret,consts,xs) = mc_expand_macro (temp,task,exp,a,ret,consts,xs) in 3265 let task = ^COMPILE_EV in 3266 (Sym "NIL",task,exp,a,ret,consts,xs,code)`; 3267 3268(* val mc_aux_tail_def = Define *) 3269val (_,mc_aux_tail_def,mc_aux_tail_pre_def) = compile "x64" `` 3270 mc_aux_tail (x0:SExp,x1,x2,x3,x4,x5,xs,code) = 3271 let x0 = x1 in 3272 if x0 = ^COMPILE_LAM1 then (* ex list has been compiled *) 3273 let x4 = HD xs in 3274 let xs = x2::xs in 3275 let x0 = ^COMPILE_LAM2 in 3276 let xs = x0::xs in 3277 let x0 = SAFE_CAR x2 in 3278 let x0 = SAFE_CDR x0 in 3279 let x0 = SAFE_CAR x0 in 3280 let x1 = Val 0 in 3281 let (x0,x1) = mc_length (x0,x1) in 3282 let x0 = x1 in 3283 let (x0,x3) = mc_drop (x0,x3) in 3284 let x1 = x0 in 3285 let x0 = SAFE_CAR x2 in 3286 let x0 = SAFE_CDR x0 in 3287 let x0 = SAFE_CAR x0 in 3288 let (x0,x1,x3) = mc_rev_append (x0,x1,x3) in 3289 let x1 = ^COMPILE_EV in 3290 let x2 = SAFE_CAR x2 in 3291 let x2 = SAFE_CDR x2 in 3292 let x2 = SAFE_CDR x2 in 3293 let x2 = SAFE_CAR x2 in 3294 let x0 = Sym "NIL" in 3295 (x0,x1,x2,x3,x4,x5,xs,code) 3296 else if x0 = ^COMPILE_LAM2 then (* add last append *) 3297 let x0 = HD xs in 3298 let xs = TL xs in 3299 let x1 = HD xs in 3300 let x3 = Val 0 in 3301 let x3 = Dot x3 x1 in 3302 let x1 = ^CONTINUE in 3303 let xs = TL xs in 3304 if x0 = Sym "T" then 3305 let x0 = Sym "NIL" in 3306 (x0,x1,x2,x3,x4,x5,xs,code) 3307 else 3308 let x0 = SAFE_CAR x2 in 3309 let x0 = SAFE_CDR x0 in 3310 let x0 = SAFE_CAR x0 in 3311 let x1 = Val 0 in 3312 let (x0,x1) = mc_length (x0,x1) in 3313 let x0 = x1 in 3314 let code = WRITE_CODE code [iPOPS (getVal x0)] in 3315 let x1 = ^CONTINUE in 3316 let x0 = Sym "NIL" in 3317 (x0,x1,x2,x3,x4,x5,xs,code) 3318 else if x0 = ^COMPILE_SET_RET then (* assign value to x4 *) 3319 let x4 = x2 in 3320 let x1 = ^CONTINUE in 3321 let x0 = Sym "NIL" in 3322 (x0,x1,x2,x3,x4,x5,xs,code) 3323 else if x0 = Sym "IF" then (* guard has been compiled *) 3324 let x0 = HD xs in 3325 let x4 = x0 in 3326 let xs = TL xs in 3327 let x0 = Val (code_ptr code) in 3328 let xs = x0::xs in 3329 let xs = x2::xs in 3330 let x0 = Val 0 in 3331 let code = WRITE_CODE code [iJNIL (getVal x0)] in 3332 let x2 = HD xs in 3333 let x3 = SAFE_CAR x2 in 3334 let x2 = SAFE_CDR x2 in 3335 let x0 = ^COMPILE_IF2 in 3336 let xs = x0::xs in 3337 let x2 = SAFE_CAR x2 in 3338 let x1 = ^COMPILE_EV in 3339 let x0 = Sym "NIL" in 3340 (x0,x1,x2,x3,x4,x5,xs,code) 3341 else if x0 = Sym "OR" then 3342 let x4 = HD xs in 3343 let xs = TL xs in 3344 let x0 = Val 0 in 3345 let code = WRITE_CODE code [iLOAD (getVal x0)] in 3346 let x0 = Val (code_ptr code) in 3347 let x5 = Dot x5 x0 in 3348 let x0 = Val 0 in 3349 let code = WRITE_CODE code [iJNIL (getVal x0)] in 3350 let x0 = SAFE_CAR x2 in 3351 let x3 = Val 0 in 3352 let x3 = Dot x3 x0 in 3353 let x0 = x1 in 3354 let (x0,x1,x3,x4,code) = mc_return_code (x0,x1,x3,x4,code) in 3355 let x1 = CDR x5 in 3356 let x5 = CAR x5 in 3357 let x0 = Val (code_ptr code) in 3358 let xs = x0::xs in 3359 let xs = x2::xs in 3360 let x0 = Val 0 in 3361 let code = WRITE_CODE code [iJUMP (getVal x0)] in 3362 let x0 = Val (code_ptr code) in 3363 let code = WRITE_CODE code [iPOP] in 3364 let code = REPLACE_CODE code (getVal x1) (iJNIL (getVal x0)) in 3365 let x2 = HD xs in 3366 let x3 = SAFE_CAR x2 in 3367 let x2 = SAFE_CDR x2 in 3368 let x0 = ^COMPILE_OR2 in 3369 let xs = x0::xs in 3370 let x0 = Sym "OR" in 3371 let x0 = Dot x0 x2 in 3372 let x2 = x0 in 3373 let x1 = ^COMPILE_EV in 3374 let x0 = Sym "NIL" in 3375 (x0,x1,x2,x3,x4,x5,xs,code) 3376 else if x0 = ^COMPILE_IF2 then (* x2 for first case has been compiled *) 3377 let x0 = Val (code_ptr code) in 3378 let x1 = HD xs in 3379 let xs = TL xs in 3380 let xs = x0::xs in 3381 let xs = x2::xs in 3382 let x0 = Val 0 in 3383 let code = WRITE_CODE code [iJUMP (getVal x0)] in 3384 let x0 = Val (code_ptr code) in 3385 let code = REPLACE_CODE code (getVal x1) (iJNIL (getVal x0)) in 3386 let x2 = HD xs in 3387 let x3 = SAFE_CAR x2 in 3388 let xs = x3::xs in 3389 let x2 = SAFE_CDR x2 in 3390 let xs = TL xs in 3391 let x0 = ^COMPILE_IF3 in 3392 let xs = x0::xs in 3393 let x2 = SAFE_CDR x2 in 3394 let x2 = SAFE_CAR x2 in 3395 let x1 = ^COMPILE_EV in 3396 let x0 = Sym "NIL" in 3397 (x0,x1,x2,x3,x4,x5,xs,code) 3398 else if x0 = ^COMPILE_IF3 then (* x2 for fst and snd case have been compiled *) 3399 let x3 = x2 in 3400 let x3 = SAFE_CAR x3 in 3401 let x0 = Val 0 in 3402 let x0 = Dot x0 x3 in 3403 let x3 = x0 in 3404 let x2 = HD xs in 3405 let xs = TL xs in 3406 let x0 = Val (code_ptr code) in 3407 let x1 = x2 in 3408 let code = REPLACE_CODE code (getVal x1) (iJUMP (getVal x0)) in 3409 let x2 = Sym "NIL" in 3410 let x1 = ^CONTINUE in 3411 let x0 = Sym "NIL" in 3412 (x0,x1,x2,x3,x4,x5,xs,code) 3413 else if x0 = ^COMPILE_OR2 then (* just fix the iJUMP *) 3414 let x3 = x2 in 3415 let x3 = SAFE_CAR x3 in 3416 let x0 = x3 in 3417 let x3 = Val 0 in 3418 let x3 = Dot x3 x0 in 3419 let x2 = HD xs in 3420 let xs = TL xs in 3421 let x0 = Val (code_ptr code) in 3422 let x1 = x2 in 3423 let code = REPLACE_CODE code (getVal x1) (iJUMP (getVal x0)) in 3424 let x2 = Sym "NIL" in 3425 let x1 = ^CONTINUE in 3426 let x0 = Sym "NIL" in 3427 (x0,x1,x2,x3,x4,x5,xs,code) 3428 else if x0 = ^COMPILE_TAILOPT then (* rearrange stack for tail call *) 3429 let xs = x4::xs in 3430 let x1 = SAFE_CAR x2 in 3431 let x0 = SAFE_CDR x2 in 3432 let x4 = x0 in 3433 let x0 = LISP_SUB x0 x1 in 3434 let x0 = LISP_ADD x0 x1 in 3435 let x1 = Val 1 in 3436 let x0 = LISP_SUB x0 x1 in 3437 let x1 = x4 in 3438 let (x0,x1,code) = mc_stores (x0,x1,code) in 3439 let x4 = HD xs in 3440 let xs = TL xs in 3441 let x0 = SAFE_CAR x2 in 3442 let x1 = SAFE_CDR x2 in 3443 let x0 = LISP_SUB x0 x1 in 3444 let (x0,code) = mc_popn (x0,code) in 3445 let x1 = ^CONTINUE in 3446 let x0 = Sym "NIL" in 3447 (x0,x1,x2,x3,x4,x5,xs,code) 3448 else if x0 = ^COMPILE_CALL then (* implements BC_call *) 3449 let x0 = Sym "NIL" in 3450 let (x0,x1,x2,x3,x4,x5,xs,code) = mc_aux_call (x0,x1,x2,x3,x4,x5,xs,code) in 3451 let x0 = Sym "NIL" in 3452 (x0,x1,x2,x3,x4,x5,xs,code) 3453 else (* if x1 = ^COMPILE_MACRO then ... *) 3454 let x0 = Sym "NIL" in 3455 let (x0,x1,x2,x3,x4,x5,xs) = mc_expand_macro (x0,x1,x2,x3,x4,x5,xs) in 3456 let x1 = ^COMPILE_EV in 3457 let x0 = Sym "NIL" in 3458 (x0,x1,x2,x3,x4,x5,xs,code)``; 3459 3460val mc_aux_tail_thm = prove( 3461 ``mc_aux_tail = BC_aux_tail``, 3462 SIMP_TAC std_ss [FUN_EQ_THM,FORALL_PROD,BC_aux_tail_def,CAR_def,CDR_def, 3463 mc_aux_tail_def,LET_DEF,HD,TL,list2sexp_def,mc_is_reserved_name_thm,getSym_def,getVal_def, 3464 mc_aux_call_thm, LISP_ADD_def,AC ADD_COMM ADD_ASSOC,SAFE_CAR_def,SAFE_CDR_def]); 3465 3466 3467val BC_aux1_def = Define ` 3468 BC_aux1 (temp:SExp,task,exp,a,ret,consts,xs,xs1,code) = 3469 if task = ^COMPILE_EV then 3470 let (temp,task,exp,a,ret,consts,xs,xs1,code) = BC_aux_ev (temp,task,exp,a,ret,consts,xs,xs1,code) in 3471 (temp,task,exp,a,ret,consts,xs,xs1,code) 3472 else if task = ^COMPILE_EVL then 3473 if isDot exp then 3474 let xs = ^COMPILE_EVL::(CDR exp)::xs in 3475 let exp = CAR exp in 3476 let task = ^COMPILE_EV in 3477 (temp,task,exp,a,ret,consts,xs,xs1,code) 3478 else 3479 let task = ^CONTINUE in 3480 (temp,task,exp,a,ret,consts,xs,xs1,code) 3481 else if task = ^COMPILE_AP then 3482 let (temp,task,exp,a,ret,xs,code) = BC_aux_ap (temp,task,exp,a,ret,xs,code) in 3483 (temp,task,exp,a,ret,consts,xs,xs1,code) 3484 else 3485 let (temp,task,exp,a,ret,consts,xs,code) = BC_aux_tail (temp,task,exp,a,ret,consts,xs,code) in 3486 (temp,task,exp,a,ret,consts,xs,xs1,code)`; 3487 3488(* val mc_aux1_def = Define *) 3489val (_,mc_aux1_def,mc_aux1_pre_def) = compile "x64" `` 3490 mc_aux1 (x0:SExp,x1,x2,x3,x4,x5,xs,xs1,code) = 3491 if x1 = ^COMPILE_EV then 3492 let (x0,x1,x2,x3,x4,x5,xs,xs1,code) = mc_aux_ev (x0,x1,x2,x3,x4,x5,xs,xs1,code) in 3493 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 3494 else if x1 = ^COMPILE_EVL then 3495 if isDot x2 then 3496 let x1 = CDR x2 in 3497 let xs = x1::xs in 3498 let x1 = ^COMPILE_EVL in 3499 let xs = x1::xs in 3500 let x2 = CAR x2 in 3501 let x1 = ^COMPILE_EV in 3502 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 3503 else 3504 let x1 = ^CONTINUE in 3505 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 3506 else if x1 = ^COMPILE_AP then 3507 let (x0,x1,x2,x3,x4,xs,code) = mc_aux_ap (x0,x1,x2,x3,x4,xs,code) in 3508 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 3509 else 3510 let (x0,x1,x2,x3,x4,x5,xs,code) = mc_aux_tail (x0,x1,x2,x3,x4,x5,xs,code) in 3511 (x0,x1,x2,x3,x4,x5,xs,xs1,code)``; 3512 3513val (_,mc_loop_def,mc_loop_pre_def) = compile "x64" `` 3514 mc_loop (x0:SExp,x1,x2,x3,x4,x5,xs,xs1,code) = 3515 if x1 = ^CONTINUE then 3516 let x1 = HD xs in 3517 let xs = TL xs in 3518 if x1 = ^CONTINUE then 3519 (x0,x1,x2,x3,x4,x5,xs,xs1,code) 3520 else 3521 let x2 = HD xs in 3522 let xs = TL xs in 3523 mc_loop (x0,x1,x2,x3,x4,x5,xs,xs1,code) 3524 else 3525 let (x0,x1,x2,x3,x4,x5,xs,xs1,code) = mc_aux1 (x0,x1,x2,x3,x4,x5,xs,xs1,code) in 3526 mc_loop (x0,x1,x2,x3,x4,x5,xs,xs1,code)``; 3527 3528 3529 3530val mc_loop_unroll = 3531 RW [mc_aux1_def,BC_aux_ev_def,BC_aux_ap_def,BC_aux_call_aux_def,BC_aux_call_def,BC_aux_tail_def, 3532 mc_aux_ev_thm,mc_aux_ap_thm,mc_aux_tail_thm,mc_aux_call_thm, 3533 mc_aux1_pre_def,mc_aux_ev_pre_def,mc_aux_ap_pre_def, 3534 mc_aux_tail_pre_def,mc_aux_call_pre_def, 3535 SAFE_CAR_def,SAFE_CDR_def] mc_loop_def; 3536 3537val mc_loop_unroll_pre = 3538 RW [mc_aux1_def,BC_aux_ev_def,BC_aux_ap_def,BC_aux_call_aux_def,BC_aux_call_def,BC_aux_tail_def, 3539 mc_aux_ev_thm,mc_aux_ap_thm,mc_aux_tail_thm,mc_aux_call_thm,mc_aux_call_aux_thm, 3540 mc_aux1_pre_def,mc_aux_ev_pre_def,mc_aux_ap_pre_def, 3541 mc_aux_tail_pre_def,mc_aux_call_pre_def,mc_aux_call_aux_pre_def, 3542 SAFE_CAR_def,SAFE_CDR_def] mc_loop_pre_def; 3543 3544val UNROLL_TAC = 3545 REPEAT STRIP_TAC 3546 \\ SIMP_TAC std_ss [Once mc_loop_unroll] 3547 \\ SIMP_TAC std_ss [Once mc_loop_unroll_pre] 3548 \\ SIMP_TAC std_ss [LET_DEF,SExp_11,SExp_distinct,term2sexp_def,func2sexp_def,isSym_def,prim2sym_def,mc_primitive_def] 3549 \\ SIMP_TAC std_ss [list2sexp_def,MAP,isDot_def,CAR_def,CDR_def,isSym_def,HD,TL] 3550 \\ SIMP_TAC (srw_ss()) [] 3551 3552val END_PROOF_TAC = 3553 FULL_SIMP_TAC std_ss [BC_return_def,mc_return_code_thm,APPEND_NIL,s2sexp_retract] 3554 \\ FULL_SIMP_TAC std_ss [a2sexp_def,a2sexp_aux_def,MAP,list2sexp_def,getVal_def,isVal_def] 3555 \\ FULL_SIMP_TAC std_ss [sexp2list_def,LENGTH,ADD1,ADD_SUB,sexp2list_list2sexp, 3556 LENGTH_MAP,WRITE_CODE_APPEND,code_ptr_WRITE_CODE,iLENGTH_thm] 3557 \\ FULL_SIMP_TAC (srw_ss()) [] 3558 \\ FULL_SIMP_TAC std_ss [GSYM BC_ADD_CONST_def,bc_inv_ADD_CONST,iLENGTH_thm] 3559 \\ METIS_TAC []; 3560 3561val bc_length_iJUMP = prove( 3562 ``!n. (bc_length (iJUMP n) = bc_length (iJUMP 0)) /\ 3563 (bc_length (iJNIL n) = bc_length (iJNIL 0))``, 3564 EVAL_TAC \\ SIMP_TAC std_ss []); 3565 3566val silly_lemma = prove( 3567 ``((if n2 = 2 then (x,Val 2,WRITE_CODE code [c1]) else 3568 if n2 = 1 then (x,Val 1,WRITE_CODE code [c2]) else 3569 (x,Val n2,WRITE_CODE code [c2])) = 3570 (x,Val n2,WRITE_CODE code [if 2 = n2 then c1 else c2])) /\ 3571 ((if n2 = 2 then (x,Val 2,WRITE_CODE code [c2]) else 3572 if n2 = 1 then (x,Val 1,WRITE_CODE code [c1]) else 3573 (x,Val n2,WRITE_CODE code [c2])) = 3574 (x,Val n2,WRITE_CODE code [if 1 = n2 then c1 else c2]))``, 3575 Cases_on `n2 = 2` \\ FULL_SIMP_TAC std_ss [] 3576 \\ Cases_on `n2 = 1` \\ FULL_SIMP_TAC std_ss []); 3577 3578 3579val mc_loop_lemma = prove( 3580 ``(!ret fc_n_a_q_bc new_code_a2_q2_bc2. 3581 BC_ap ret fc_n_a_q_bc new_code_a2_q2_bc2 ==> 3582 !fc n a fl q bc new_code a2 q2 bc2 xs code. 3583 (fc_n_a_q_bc = (fc,n,a,q,bc)) /\ (new_code_a2_q2_bc2 = (new_code,a2,q2,bc2)) /\ 3584 bc_inv bc /\ (q = code_ptr code) ==> 3585 ?exp2. 3586 (mc_loop_pre (Sym "NIL",^COMPILE_AP,Dot (HD (func2sexp fc)) (Val n),a2sexp a,bool2sexp ret,bc_state_tree bc,xs,bc.consts,code) = 3587 mc_loop_pre (Sym "NIL",^CONTINUE,exp2,a2sexp a2,bool2sexp ret,bc_state_tree bc2,xs,bc2.consts,WRITE_CODE code new_code)) /\ 3588 (mc_loop (Sym "NIL",^COMPILE_AP,Dot (HD (func2sexp fc)) (Val n),a2sexp a,bool2sexp ret,bc_state_tree bc,xs,bc.consts,code) = 3589 mc_loop (Sym "NIL",^CONTINUE,exp2,a2sexp a2,bool2sexp ret,bc_state_tree bc2,xs,bc2.consts,WRITE_CODE code new_code)) /\ 3590 bc_inv bc2 /\ (bc2.compiled = bc.compiled) /\ (q2 = code_ptr (WRITE_CODE code new_code))) /\ 3591 (!xs_a_q_bc new_code_a2_q2_bc2. 3592 BC_evl xs_a_q_bc new_code_a2_q2_bc2 ==> 3593 !xs a q bc new_code a2 q2 bc2 ys code. 3594 (xs_a_q_bc = (xs,a,q,bc)) /\ (new_code_a2_q2_bc2 = (new_code,a2,q2,bc2)) /\ 3595 bc_inv bc /\ (q = code_ptr code) ==> 3596 ?exp2. 3597 (mc_loop_pre (Sym "NIL",^COMPILE_EVL,list2sexp (MAP term2sexp xs),a2sexp a,bool2sexp F,bc_state_tree bc,ys,bc.consts,code) = 3598 mc_loop_pre (Sym "NIL",^CONTINUE,exp2,a2sexp a2,bool2sexp F,bc_state_tree bc2,ys,bc2.consts,WRITE_CODE code new_code)) /\ 3599 (mc_loop (Sym "NIL",^COMPILE_EVL,list2sexp (MAP term2sexp xs),a2sexp a,bool2sexp F,bc_state_tree bc,ys,bc.consts,code) = 3600 mc_loop (Sym "NIL",^CONTINUE,exp2,a2sexp a2,bool2sexp F,bc_state_tree bc2,ys,bc2.consts,WRITE_CODE code new_code)) /\ 3601 bc_inv bc2 /\ (bc2.compiled = bc.compiled) /\ (q2 = code_ptr (WRITE_CODE code new_code))) /\ 3602 (!ret x_a_q_bc new_code_a2_q2_bc2. 3603 BC_ev ret x_a_q_bc new_code_a2_q2_bc2 ==> 3604 !x a q bc new_code a2 q2 bc2 xs code. 3605 (x_a_q_bc = (x,a,q,bc)) /\ (new_code_a2_q2_bc2 = (new_code,a2,q2,bc2)) /\ 3606 bc_inv bc /\ (q = code_ptr code) ==> 3607 ?exp2. 3608 (mc_loop_pre (Sym "NIL",^COMPILE_EV,term2sexp x,a2sexp a,bool2sexp ret,bc_state_tree bc,xs,bc.consts,code) = 3609 mc_loop_pre (Sym "NIL",^CONTINUE,exp2,a2sexp a2,bool2sexp ret,bc_state_tree bc2,xs,bc2.consts,WRITE_CODE code new_code)) /\ 3610 (mc_loop (Sym "NIL",^COMPILE_EV,term2sexp x,a2sexp a,bool2sexp ret,bc_state_tree bc,xs,bc.consts,code) = 3611 mc_loop (Sym "NIL",^CONTINUE,exp2,a2sexp a2,bool2sexp ret,bc_state_tree bc2,xs,bc2.consts,WRITE_CODE code new_code)) /\ 3612 bc_inv bc2 /\ (bc2.compiled = bc.compiled) /\ (q2 = code_ptr (WRITE_CODE code new_code)))``, 3613 HO_MATCH_MP_TAC BC_ev_ind \\ SIMP_TAC std_ss [] 3614 \\ STRIP_TAC (* quote *) THEN1 3615 (STRIP_TAC \\ FULL_SIMP_TAC std_ss [term2sexp_def] 3616 \\ SIMP_TAC std_ss [Once mc_loop_unroll] 3617 \\ SIMP_TAC std_ss [Once mc_loop_unroll_pre,LISP_TEST_EQ_T] 3618 \\ SIMP_TAC std_ss [LET_DEF,SExp_11,SExp_distinct,term2sexp_def,isSym_def] 3619 \\ SIMP_TAC std_ss [list2sexp_def,CAR_def,CDR_def,isDot_def,isSym_def,isVal_def,isQuote_def,LISP_TEST_EQ_T] 3620 \\ SIMP_TAC (srw_ss()) [] \\ NTAC 3 STRIP_TAC 3621 \\ Cases_on `isVal s` \\ FULL_SIMP_TAC std_ss [] THEN1 3622 (`~(isDot s)` by FULL_SIMP_TAC std_ss [isDot_def,isVal_thm] 3623 \\ FULL_SIMP_TAC std_ss [] \\ END_PROOF_TAC) 3624 \\ Cases_on `isSym s` \\ FULL_SIMP_TAC std_ss [] THEN1 3625 (`~(isDot s)` by FULL_SIMP_TAC std_ss [isDot_def,isSym_thm] 3626 \\ FULL_SIMP_TAC std_ss [] \\ END_PROOF_TAC) 3627 \\ `isDot s` by (Cases_on `s` \\ FULL_SIMP_TAC std_ss [isDot_def,isSym_def,isVal_def]) 3628 \\ FULL_SIMP_TAC std_ss [getVal_def,BC_ADD_CONST_def] 3629 \\ END_PROOF_TAC) 3630 \\ STRIP_TAC (* var lookup *) THEN1 3631 (STRIP_TAC \\ FULL_SIMP_TAC std_ss [term2sexp_def] 3632 \\ SIMP_TAC std_ss [Once mc_loop_unroll] 3633 \\ SIMP_TAC std_ss [Once mc_loop_unroll_pre,LISP_TEST_EQ_T] 3634 \\ SIMP_TAC std_ss [LET_DEF,SExp_11,SExp_distinct,term2sexp_def,isSym_def] 3635 \\ SIMP_TAC (srw_ss()) [HD,TL,NOT_CONS_NIL] 3636 \\ NTAC 5 STRIP_TAC \\ Cases_on `var_lookup 0 v a` 3637 \\ IMP_RES_TAC mc_alist_lookup_NONE 3638 \\ IMP_RES_TAC mc_alist_lookup_thm 3639 \\ REPEAT (Q.PAT_X_ASSUM `!x0.bbb` (STRIP_ASSUME_TAC o Q.SPEC `Val 0`)) 3640 \\ ASM_SIMP_TAC std_ss [SExp_distinct,getVal_def] 3641 \\ END_PROOF_TAC) 3642 \\ STRIP_TAC (* FunApp *) THEN1 3643 (REPEAT STRIP_TAC \\ FULL_SIMP_TAC std_ss [] 3644 \\ SIMP_TAC std_ss [Once mc_loop_unroll] 3645 \\ SIMP_TAC std_ss [Once mc_loop_unroll_pre] 3646 \\ SIMP_TAC std_ss [LET_DEF,SExp_11,SExp_distinct,isSym_def,prim2sym_def,mc_primitive_def] 3647 \\ ASM_SIMP_TAC std_ss [term2sexp_guard_lemma,NOT_isFun_IMP_guard] 3648 \\ `(CDR (term2sexp (App fc xs)) = list2sexp (MAP term2sexp xs)) /\ 3649 (CAR (term2sexp (App fc xs)) = HD (func2sexp fc))` by 3650 (Cases_on `fc` \\ FULL_SIMP_TAC std_ss [term2sexp_def,isFun_def, 3651 func2sexp_def,APPEND,list2sexp_def,CDR_def,CAR_def,ETA_AX,HD]) 3652 \\ ASM_SIMP_TAC std_ss [mc_length_thm,LENGTH_MAP,CAR_def,CDR_def,NOT_CONS_NIL, 3653 HD,TL,LISP_TEST_EQ_T,term2sexp_guard_lemma,mc_is_reserved_name_thm, 3654 NOT_isFun_IMP_guard] 3655 \\ Q.PAT_ABBREV_TAC `xsss = ^COMPILE_SET_RET::nothing` 3656 \\ Q.PAT_X_ASSUM `!xs.bbb` MP_TAC 3657 \\ Q.PAT_X_ASSUM `!xs.bbb` (STRIP_ASSUME_TAC o Q.SPECL [`xsss`,`code`]) 3658 \\ FULL_SIMP_TAC std_ss [bool2sexp_def] \\ POP_ASSUM (K ALL_TAC) 3659 \\ Q.UNABBREV_TAC `xsss` 3660 \\ UNROLL_TAC 3661 \\ UNROLL_TAC 3662 \\ UNROLL_TAC 3663 \\ Q.PAT_X_ASSUM `!xs.bbb` (STRIP_ASSUME_TAC o Q.SPECL [`xs'`,`WRITE_CODE code code1`]) 3664 \\ FULL_SIMP_TAC std_ss [WRITE_CODE_APPEND] \\ METIS_TAC []) 3665 \\ STRIP_TAC (* iDATA *) THEN1 3666 (REPEAT STRIP_TAC \\ Cases_on `fc` 3667 \\ Q.PAT_X_ASSUM `EVAL_DATA_OP xxx = (f,n1)` (ASSUME_TAC o RW [EVAL_DATA_OP_def] o GSYM) 3668 \\ UNROLL_TAC \\ FULL_SIMP_TAC std_ss [silly_lemma,mc_drop_thm] 3669 \\ Q.PAT_X_ASSUM `BC_return ret xxx = yyy` (ASSUME_TAC o GSYM) \\ END_PROOF_TAC) 3670 \\ STRIP_TAC (* App -- ret false *) THEN1 3671 (REPEAT STRIP_TAC \\ FULL_SIMP_TAC std_ss [] 3672 \\ SIMP_TAC std_ss [Once mc_loop_unroll] 3673 \\ SIMP_TAC std_ss [Once mc_loop_unroll_pre] 3674 \\ SIMP_TAC std_ss [LET_DEF,SExp_11,SExp_distinct,isSym_def,prim2sym_def,mc_primitive_def] 3675 \\ ASM_SIMP_TAC std_ss [term2sexp_guard_lemma,bool2sexp_def] 3676 \\ FULL_SIMP_TAC std_ss [BC_is_reserved_name_Fun,bool2sexp_def, 3677 mc_is_reserved_name_thm,mc_strip_app_thm,LISP_TEST_EQ_T] 3678 \\ Q.PAT_ABBREV_TAC `xsss = ^COMPILE_CALL::nothing` 3679 \\ Q.PAT_X_ASSUM `!ys.bbb` (STRIP_ASSUME_TAC o RW [] o Q.SPECL [`xsss`,`code'`]) 3680 \\ ASM_SIMP_TAC std_ss [list2sexp_def,CDR_def] 3681 \\ Q.UNABBREV_TAC `xsss` 3682 \\ UNROLL_TAC 3683 \\ UNROLL_TAC 3684 \\ FULL_SIMP_TAC std_ss [mc_length_thm,mc_drop_thm] 3685 \\ Cases_on `FUN_LOOKUP bc2.compiled fc` THEN1 3686 (Q.PAT_X_ASSUM `bc2.compiled = bc.compiled` (ASSUME_TAC o GSYM) 3687 \\ ASM_SIMP_TAC std_ss [BC_call_def,BC_call_aux_def,APPEND,WRITE_CODE_APPEND,getSym_def] 3688 \\ IMP_RES_TAC mc_fun_lookup_NONE_bc \\ ASM_SIMP_TAC std_ss [] 3689 \\ Q.PAT_X_ASSUM `!x0:SExp.bbb` (STRIP_ASSUME_TAC o Q.SPEC `^COMPILE_CALL`) 3690 \\ FULL_SIMP_TAC std_ss [mc_length_thm,mc_drop_thm,LENGTH_MAP,getVal_def] 3691 \\ FULL_SIMP_TAC std_ss [a2sexp_def,MAP,a2sexp_aux_def,list2sexp_def,isVal_def] 3692 \\ Q.EXISTS_TAC `Sym "NIL"` \\ ASM_SIMP_TAC std_ss [] 3693 \\ IMP_RES_TAC iLENGTH_thm 3694 \\ ASM_SIMP_TAC std_ss [code_ptr_WRITE_CODE,code_length_APPEND,AC ADD_COMM ADD_ASSOC]) 3695 \\ Q.PAT_X_ASSUM `bc2.compiled = bc.compiled` (ASSUME_TAC o GSYM) 3696 \\ Cases_on `x` 3697 \\ ASM_SIMP_TAC std_ss [BC_call_def,APPEND,WRITE_CODE_APPEND,getSym_def] 3698 \\ IMP_RES_TAC mc_fun_lookup_SOME_bc \\ ASM_SIMP_TAC std_ss [] 3699 \\ REPEAT (Q.PAT_X_ASSUM `!x0:SExp.bbb` (STRIP_ASSUME_TAC o Q.SPEC `^COMPILE_CALL`)) 3700 \\ FULL_SIMP_TAC std_ss [mc_length_thm,mc_drop_thm,LENGTH_MAP,getVal_def] 3701 \\ FULL_SIMP_TAC std_ss [a2sexp_def,MAP,a2sexp_aux_def,list2sexp_def,isVal_def] 3702 \\ SIMP_TAC (srw_ss()) [CDR_def,CAR_def] 3703 \\ Cases_on `r = LENGTH xs` \\ ASM_SIMP_TAC (srw_ss()) [] 3704 \\ Q.EXISTS_TAC `Sym "NIL"` \\ ASM_SIMP_TAC std_ss [BC_call_aux_def,getVal_def] 3705 \\ IMP_RES_TAC iLENGTH_thm 3706 \\ ASM_SIMP_TAC std_ss [code_ptr_WRITE_CODE,code_length_APPEND,AC ADD_COMM ADD_ASSOC] 3707 \\ SIMP_TAC std_ss [isDot_def,isVal_def,markerTheory.Abbrev_def]) 3708 \\ STRIP_TAC (* App -- ret true *) THEN1 3709 (REPEAT STRIP_TAC \\ FULL_SIMP_TAC std_ss [] 3710 \\ SIMP_TAC std_ss [Once mc_loop_unroll] 3711 \\ SIMP_TAC std_ss [Once mc_loop_unroll_pre] 3712 \\ SIMP_TAC std_ss [LET_DEF,SExp_11,SExp_distinct,isSym_def,prim2sym_def,mc_primitive_def] 3713 \\ ASM_SIMP_TAC std_ss [term2sexp_guard_lemma,bool2sexp_def] 3714 \\ FULL_SIMP_TAC std_ss [BC_is_reserved_name_Fun,bool2sexp_def, 3715 mc_is_reserved_name_thm,mc_strip_app_thm] 3716 \\ SIMP_TAC (srw_ss()) [] 3717 \\ FULL_SIMP_TAC std_ss [list2sexp_def,CDR_def] 3718 \\ FULL_SIMP_TAC std_ss [a2sexp_def,mc_length_thm,LENGTH_MAP] 3719 \\ SIMP_TAC std_ss [LISP_SUB_def,getVal_def] 3720 \\ FULL_SIMP_TAC std_ss [GSYM a2sexp_def,mc_push_nils_thm,LISP_TEST_EQ_T,CAR_def,isVal_def] 3721 \\ Q.PAT_ABBREV_TAC `xsss = ^COMPILE_TAILOPT::nothing` 3722 \\ Q.PAT_X_ASSUM `!ys.bbb` (MP_TAC o RW [] o Q.SPECL [`xsss`,`WRITE_CODE code' 3723 (n_times (LENGTH (xs:term list) - LENGTH (a:stack_slot list)) (iCONST_SYM "NIL"))`]) 3724 \\ MATCH_MP_TAC IMP_IMP \\ STRIP_TAC THEN1 3725 (IMP_RES_TAC iLENGTH_thm 3726 \\ FULL_SIMP_TAC std_ss [code_ptr_WRITE_CODE,code_length_def]) 3727 \\ STRIP_TAC 3728 \\ FULL_SIMP_TAC std_ss [] 3729 \\ Q.UNABBREV_TAC `xsss` 3730 \\ UNROLL_TAC 3731 \\ UNROLL_TAC 3732 \\ FULL_SIMP_TAC std_ss [LISP_ADD_def,LISP_SUB_def,getVal_def, 3733 mc_popn_thm,mc_stores_thm,WRITE_CODE_APPEND,APPEND_ASSOC] 3734 \\ UNROLL_TAC 3735 \\ UNROLL_TAC 3736 \\ UNROLL_TAC 3737 \\ UNROLL_TAC 3738 \\ FULL_SIMP_TAC std_ss [isVal_def,getSym_def,mc_length_thm,mc_drop_thm] 3739 \\ FULL_SIMP_TAC std_ss [WRITE_CODE_APPEND,APPEND] 3740 \\ Q.PAT_X_ASSUM `bc2.compiled = bc.compiled` (ASSUME_TAC o GSYM) 3741 \\ Cases_on `FUN_LOOKUP bc2.compiled fc` THEN1 3742 (Q.PAT_X_ASSUM `_.compiled = _.compiled` (ASSUME_TAC o GSYM) 3743 \\ ASM_SIMP_TAC std_ss [BC_call_def,BC_call_aux_def,APPEND,WRITE_CODE_APPEND,getSym_def] 3744 \\ IMP_RES_TAC mc_fun_lookup_NONE_bc \\ ASM_SIMP_TAC std_ss [] 3745 \\ Q.PAT_X_ASSUM `!x0:SExp.bbb` (STRIP_ASSUME_TAC o Q.SPEC `^COMPILE_CALL`) 3746 \\ FULL_SIMP_TAC std_ss [mc_length_thm,mc_drop_thm,LENGTH_MAP,getVal_def] 3747 \\ FULL_SIMP_TAC std_ss [a2sexp_def,MAP,a2sexp_aux_def,list2sexp_def,isVal_def] 3748 \\ Q.EXISTS_TAC `Sym "NIL"` \\ ASM_SIMP_TAC std_ss [BC_call_def,BC_call_aux_def] 3749 \\ IMP_RES_TAC iLENGTH_thm 3750 \\ ASM_SIMP_TAC std_ss [code_ptr_WRITE_CODE,code_length_APPEND,AC ADD_COMM ADD_ASSOC]) 3751 \\ Q.PAT_X_ASSUM `_.compiled = _.compiled` (ASSUME_TAC o GSYM) 3752 \\ Cases_on `x` 3753 \\ ASM_SIMP_TAC std_ss [BC_call_def,APPEND,WRITE_CODE_APPEND,getSym_def] 3754 \\ IMP_RES_TAC mc_fun_lookup_SOME_bc \\ ASM_SIMP_TAC std_ss [] 3755 \\ REPEAT (Q.PAT_X_ASSUM `!x0:SExp.bbb` (STRIP_ASSUME_TAC o Q.SPEC `^COMPILE_CALL`)) 3756 \\ FULL_SIMP_TAC std_ss [mc_length_thm,mc_drop_thm,LENGTH_MAP,getVal_def] 3757 \\ FULL_SIMP_TAC std_ss [a2sexp_def,MAP,a2sexp_aux_def,list2sexp_def,isVal_def] 3758 \\ SIMP_TAC (srw_ss()) [CDR_def,CAR_def] 3759 \\ Cases_on `r = LENGTH xs` \\ ASM_SIMP_TAC (srw_ss()) [] 3760 \\ Q.EXISTS_TAC `Sym "NIL"` \\ ASM_SIMP_TAC std_ss [BC_call_def,BC_call_aux_def,getVal_def] 3761 \\ IMP_RES_TAC iLENGTH_thm 3762 \\ ASM_SIMP_TAC std_ss [code_ptr_WRITE_CODE,code_length_APPEND,AC ADD_COMM ADD_ASSOC] 3763 \\ SIMP_TAC std_ss [isDot_def,isVal_def,markerTheory.Abbrev_def]) 3764 \\ STRIP_TAC (* If *) THEN1 3765 (ASM_SIMP_TAC std_ss [] \\ UNROLL_TAC \\ FULL_SIMP_TAC std_ss [] 3766 \\ Q.PAT_ABBREV_TAC `xsss = Sym "IF"::nothing` 3767 \\ Q.PAT_X_ASSUM `!xs.bbb` MP_TAC \\ Q.PAT_X_ASSUM `!xs.bbb` MP_TAC 3768 \\ Q.PAT_X_ASSUM `!xs.bbb` (STRIP_ASSUME_TAC o Q.SPECL [`xsss`,`code`]) 3769 \\ Q.UNABBREV_TAC `xsss` 3770 \\ FULL_SIMP_TAC std_ss [bool2sexp_def] \\ POP_ASSUM (K ALL_TAC) 3771 \\ UNROLL_TAC 3772 \\ UNROLL_TAC 3773 \\ SIMP_TAC (srw_ss()) [getVal_def,isVal_def] 3774 \\ Q.PAT_ABBREV_TAC `xsss = ^COMPILE_IF2::nothing` 3775 \\ Q.PAT_X_ASSUM `!xs.bbb` MP_TAC 3776 \\ Q.PAT_X_ASSUM `!xs.bbb` (MP_TAC o Q.SPECL [`xsss`,`WRITE_CODE (WRITE_CODE code x_code) [iJNIL 0]`]) 3777 \\ MATCH_MP_TAC IMP_IMP \\ STRIP_TAC 3778 THEN1 (FULL_SIMP_TAC std_ss [code_ptr_WRITE_CODE,code_length_def,bc_inv_def] \\ EVAL_TAC) 3779 \\ STRIP_TAC 3780 \\ Q.UNABBREV_TAC `xsss` 3781 \\ ASM_SIMP_TAC std_ss [] \\ POP_ASSUM (K ALL_TAC) \\ REPEAT STRIP_TAC 3782 \\ UNROLL_TAC 3783 \\ UNROLL_TAC 3784 \\ SIMP_TAC std_ss [getVal_def] 3785 \\ Q.PAT_ABBREV_TAC `xsss = ^COMPILE_IF3::nothing` 3786 \\ Q.PAT_ABBREV_TAC `rep_code = REPLACE_CODE xx yy zz` 3787 \\ Q.PAT_X_ASSUM `!xs.bbb` (MP_TAC o Q.SPECL [`xsss`,`rep_code`]) 3788 \\ MATCH_MP_TAC IMP_IMP \\ STRIP_TAC THEN1 3789 (Q.UNABBREV_TAC `rep_code` 3790 \\ FULL_SIMP_TAC std_ss [code_ptr_WRITE_CODE,code_ptr_REPLACE_CODE, 3791 code_length_def,bc_inv_def] \\ EVAL_TAC) 3792 \\ STRIP_TAC 3793 \\ ASM_SIMP_TAC std_ss [] \\ POP_ASSUM (K ALL_TAC) 3794 \\ Q.UNABBREV_TAC `xsss` \\ Q.UNABBREV_TAC `rep_code` 3795 \\ UNROLL_TAC 3796 \\ UNROLL_TAC 3797 \\ Q.EXISTS_TAC `Sym "NIL"` 3798 \\ ASM_SIMP_TAC std_ss [a2sexp_def,a2sexp_aux_def,MAP,list2sexp_def,getVal_def,isVal_def] 3799 \\ SIMP_TAC std_ss [CONJ_ASSOC] 3800 \\ REVERSE STRIP_TAC THEN1 3801 (FULL_SIMP_TAC std_ss [code_ptr_WRITE_CODE,code_ptr_REPLACE_CODE, 3802 code_length_def,bc_inv_def,code_length_APPEND] 3803 \\ ONCE_REWRITE_TAC [bc_length_iJUMP] 3804 \\ FULL_SIMP_TAC std_ss [AC ADD_COMM ADD_ASSOC]) 3805 \\ ASM_SIMP_TAC std_ss [WRITE_CODE_APPEND] 3806 \\ ASM_SIMP_TAC std_ss [SND_WRITE_CODE] 3807 \\ Q.PAT_ABBREV_TAC `new_jnil_offset = (code_ptr code + code_length (xxss ++ yyss))` 3808 \\ `bc_length (iJNIL 0) = bc_length (iJNIL new_jnil_offset)` by EVAL_TAC 3809 \\ IMP_RES_TAC REPLACE_CODE_RW \\ ASM_SIMP_TAC std_ss [] 3810 \\ ASM_SIMP_TAC std_ss [SND_WRITE_CODE,WRITE_CODE_APPEND,code_ptr_REPLACE_CODE] 3811 \\ Q.ABBREV_TAC `new_jump_offset = (code_ptr code + 3812 code_length 3813 (x_code ++ ([iJNIL new_jnil_offset] ++ (y_code ++ [iJUMP 0]))) + 3814 code_length z_code)` 3815 \\ `bc_length (iJUMP 0) = bc_length (iJUMP new_jump_offset)` by EVAL_TAC 3816 \\ IMP_RES_TAC REPLACE_CODE_RW \\ ASM_SIMP_TAC std_ss [] 3817 \\ POP_ASSUM (ASSUME_TAC o Q.SPECL [`z_code`,`x_code ++ [iJNIL new_jnil_offset] ++ y_code`]) 3818 \\ FULL_SIMP_TAC std_ss [code_length_APPEND,code_length_def,APPEND_ASSOC, 3819 AC ADD_COMM ADD_ASSOC,getVal_def,isVal_def] 3820 \\ ASM_SIMP_TAC std_ss [APPEND_11,CONS_11] 3821 \\ SIMP_TAC (srw_ss()) [] 3822 \\ Q.UNABBREV_TAC `new_jnil_offset` 3823 \\ ONCE_REWRITE_TAC [bc_length_iJUMP] 3824 \\ FULL_SIMP_TAC std_ss [bc_inv_def] 3825 \\ Q.PAT_ABBREV_TAC `xxx = mc_loop_pre xxxx` 3826 \\ Cases_on `xxx` \\ ASM_SIMP_TAC std_ss [] 3827 \\ ONCE_REWRITE_TAC [bc_length_iJUMP] 3828 \\ SIMP_TAC std_ss [GSYM APPEND_ASSOC,APPEND] 3829 \\ SIMP_TAC std_ss [code_mem_WRITE_CODE] 3830 \\ Q.PAT_ABBREV_TAC `jnil = iJNIL (xxx + yyy)` 3831 \\ `x_code ++ jnil::(y_code ++ iJUMP 0::z_code) = 3832 (x_code ++ jnil::y_code) ++ iJUMP 0::z_code` by 3833 (FULL_SIMP_TAC std_ss [GSYM APPEND_ASSOC,APPEND]) 3834 \\ Q.PAT_ABBREV_TAC `l = code_length x_code + xxx` 3835 \\ `l = code_length (x_code ++ jnil::y_code) + code_ptr code` by 3836 (Q.UNABBREV_TAC `l` \\ Q.UNABBREV_TAC `jnil` 3837 \\ SIMP_TAC std_ss [code_length_APPEND,code_length_def] 3838 \\ ONCE_REWRITE_TAC [bc_length_iJUMP] 3839 \\ SIMP_TAC std_ss [AC ADD_ASSOC ADD_COMM]) 3840 \\ FULL_SIMP_TAC std_ss [code_mem_WRITE_CODE]) 3841 \\ STRIP_TAC (* Or -- base case *) THEN1 3842 (REPEAT STRIP_TAC \\ FULL_SIMP_TAC std_ss [term2sexp_def] 3843 \\ SIMP_TAC std_ss [Once mc_loop_unroll] 3844 \\ SIMP_TAC std_ss [Once mc_loop_unroll_pre] 3845 \\ SIMP_TAC std_ss [LET_DEF,SExp_11,SExp_distinct,isSym_def,prim2sym_def, 3846 mc_primitive_def,list2sexp_def,MAP,CAR_def,CDR_def,isDot_def] 3847 \\ ASM_SIMP_TAC (srw_ss()) [getSym_def] 3848 \\ Q.PAT_X_ASSUM `!xs.bbb` (STRIP_ASSUME_TAC o RW [] o Q.SPECL [`xs`,`code'`] o GSYM) 3849 \\ Q.EXISTS_TAC `exp2` \\ ASM_SIMP_TAC std_ss [] 3850 \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] 3851 \\ SIMP_TAC std_ss [Once mc_loop_unroll] 3852 \\ SIMP_TAC std_ss [Once mc_loop_unroll_pre] 3853 \\ SIMP_TAC std_ss [LET_DEF,SExp_11,SExp_distinct,isSym_def,prim2sym_def,isQuote_def, 3854 mc_primitive_def,list2sexp_def,MAP,CAR_def,CDR_def,isDot_def,isVal_def] 3855 \\ ASM_SIMP_TAC (srw_ss()) [getSym_def,isSym_def,LISP_TEST_EQ_T]) 3856 \\ STRIP_TAC (* Or -- step case *) THEN1 3857 (ASM_SIMP_TAC std_ss [] \\ UNROLL_TAC \\ FULL_SIMP_TAC std_ss [] 3858 \\ Q.PAT_ABBREV_TAC `xsss = Sym "OR"::nothing` 3859 \\ Q.PAT_X_ASSUM `!xs.bbb` MP_TAC 3860 \\ Q.PAT_X_ASSUM `!xs.bbb` (STRIP_ASSUME_TAC o Q.SPECL [`xsss`,`code`]) 3861 \\ Q.UNABBREV_TAC `xsss` 3862 \\ FULL_SIMP_TAC std_ss [bool2sexp_def] 3863 \\ UNROLL_TAC 3864 \\ UNROLL_TAC 3865 \\ SIMP_TAC (srw_ss()) [getVal_def] 3866 \\ SIMP_TAC std_ss [WRITE_CODE_APPEND,code_ptr_WRITE_CODE,s2sexp_retract, 3867 mc_return_code_thm,APPEND_ASSOC,ETA_AX] 3868 \\ Q.PAT_ABBREV_TAC `xsss = ^COMPILE_OR2::nothing` 3869 \\ FULL_SIMP_TAC std_ss [term2sexp_def,list2sexp_def,ETA_AX] 3870 \\ Q.PAT_ABBREV_TAC `new_code = REPLACE_CODE xx yy zz` 3871 \\ Q.PAT_X_ASSUM `!xx yy. bb` (MP_TAC o RW [] o Q.SPECL [`xsss`,`new_code`]) 3872 \\ MATCH_MP_TAC IMP_IMP \\ STRIP_TAC THEN1 3873 (Q.UNABBREV_TAC `new_code` \\ IMP_RES_TAC iLENGTH_thm 3874 \\ FULL_SIMP_TAC std_ss [code_ptr_WRITE_CODE, 3875 code_length_def,code_ptr_REPLACE_CODE,iLENGTH_thm] 3876 \\ FULL_SIMP_TAC std_ss [code_length_APPEND,AC ADD_COMM ADD_ASSOC, 3877 code_length_def] \\ ONCE_REWRITE_TAC [bc_length_iJUMP] 3878 \\ FULL_SIMP_TAC std_ss [AC ADD_COMM ADD_ASSOC]) 3879 \\ STRIP_TAC 3880 \\ ASM_SIMP_TAC std_ss [isVal_def] 3881 \\ Q.UNABBREV_TAC `xsss` 3882 \\ ASM_SIMP_TAC std_ss [] 3883 \\ UNROLL_TAC 3884 \\ UNROLL_TAC 3885 \\ SIMP_TAC std_ss [getVal_def,s2sexp_retract,isVal_def] 3886 \\ Q.EXISTS_TAC `Sym "NIL"` 3887 \\ ASM_SIMP_TAC std_ss [code_ptr_WRITE_CODE] 3888 \\ SIMP_TAC std_ss [CONJ_ASSOC] 3889 \\ REVERSE STRIP_TAC THEN1 3890 (Q.UNABBREV_TAC `new_code` 3891 \\ FULL_SIMP_TAC std_ss [code_ptr_WRITE_CODE,code_ptr_REPLACE_CODE, 3892 code_length_def,bc_inv_def,code_length_APPEND] 3893 \\ ONCE_REWRITE_TAC [bc_length_iJUMP] 3894 \\ FULL_SIMP_TAC std_ss [AC ADD_COMM ADD_ASSOC]) 3895 \\ ASM_SIMP_TAC std_ss [] 3896 \\ Q.UNABBREV_TAC `new_code` 3897 \\ ASM_SIMP_TAC std_ss [SND_WRITE_CODE,WRITE_CODE_APPEND,code_ptr_REPLACE_CODE] 3898 \\ Q.ABBREV_TAC `new_jnil_offset = (code_ptr code + 3899 code_length 3900 (x_code ++ [iLOAD 0] ++ [iJNIL 0] ++ 3901 BC_return_code ret (ssTEMP::a)) + 3902 code_length [iJUMP 0])` 3903 \\ Q.ABBREV_TAC `new_jump_offset = (code_ptr code + 3904 code_length 3905 (x_code ++ [iLOAD 0] ++ [iJNIL 0] ++ 3906 BC_return_code ret (ssTEMP::a) ++ [iJUMP 0] ++ [iPOP]) + 3907 code_length z_code)` 3908 \\ `bc_length (iJNIL 0) = bc_length (iJNIL new_jnil_offset)` by EVAL_TAC 3909 \\ IMP_RES_TAC REPLACE_CODE_RW 3910 \\ POP_ASSUM (ASSUME_TAC o Q.SPECL [`BC_return_code ret (ssTEMP::a) ++ [iJUMP 0] ++ [iPOP]`, 3911 `x_code ++ [iLOAD 0]`,`code`]) 3912 \\ FULL_SIMP_TAC std_ss [APPEND_ASSOC,code_length_APPEND,ADD_ASSOC,WRITE_CODE_APPEND] 3913 \\ `bc_length (iJUMP 0) = bc_length (iJUMP new_jump_offset)` by EVAL_TAC 3914 \\ Q.PAT_X_ASSUM `bc_length (iJNIL 0) = bc_length (iJNIL new_jnil_offset)` MP_TAC 3915 \\ IMP_RES_TAC REPLACE_CODE_RW 3916 \\ POP_ASSUM (ASSUME_TAC o Q.SPECL [`[iPOP] ++ z_code`, 3917 `x_code ++ [iLOAD 0] ++ [iJNIL new_jnil_offset] ++ 3918 BC_return_code ret (ssTEMP::a)`,`code`]) 3919 \\ REPEAT STRIP_TAC 3920 \\ FULL_SIMP_TAC std_ss [APPEND_ASSOC,code_length_APPEND, 3921 AC ADD_COMM ADD_ASSOC,WRITE_CODE_APPEND,code_length_def] 3922 \\ SIMP_TAC std_ss [GSYM APPEND_ASSOC,APPEND] 3923 \\ `new_jnil_offset = addr + code_ptr code` by 3924 (Q.UNABBREV_TAC `new_jnil_offset` 3925 \\ Q.PAT_X_ASSUM `addr = xxx` (fn th => ONCE_REWRITE_TAC [th]) 3926 \\ SIMP_TAC std_ss [code_ptr_WRITE_CODE,code_ptr_REPLACE_CODE, 3927 code_length_def,bc_inv_def,code_length_APPEND] 3928 \\ IMP_RES_TAC iLENGTH_thm 3929 \\ ASM_SIMP_TAC std_ss [code_length_def,code_length_APPEND] 3930 \\ ONCE_REWRITE_TAC [bc_length_iJUMP] 3931 \\ FULL_SIMP_TAC std_ss [AC ADD_COMM ADD_ASSOC]) 3932 \\ ASM_SIMP_TAC std_ss [] 3933 \\ Q.PAT_ABBREV_TAC `xxx = mc_loop_pre yyy` 3934 \\ Cases_on `xxx` \\ ASM_SIMP_TAC std_ss [] 3935 \\ REPEAT STRIP_TAC THEN1 3936 (SIMP_TAC std_ss [APPEND_ASSOC,Once (GSYM (EVAL ``[x;y]++xs``))] 3937 \\ MATCH_MP_TAC code_mem_WRITE_CODE_IMP 3938 \\ SIMP_TAC std_ss [code_length_APPEND,code_length_def, 3939 AC ADD_ASSOC ADD_COMM]) 3940 \\ SIMP_TAC std_ss [APPEND_ASSOC,Once (GSYM (EVAL ``[x]++xs``))] 3941 \\ MATCH_MP_TAC code_mem_WRITE_CODE_IMP 3942 \\ SIMP_TAC std_ss [code_length_APPEND,code_length_def, 3943 AC ADD_ASSOC ADD_COMM]) 3944 \\ STRIP_TAC (* LamApp *) THEN1 3945 (REPEAT STRIP_TAC \\ FULL_SIMP_TAC std_ss [] 3946 \\ SIMP_TAC std_ss [Once mc_loop_unroll] 3947 \\ SIMP_TAC std_ss [Once mc_loop_unroll_pre] 3948 \\ SIMP_TAC std_ss [LET_DEF,SExp_11,SExp_distinct,term2sexp_def,func2sexp_def,isSym_def] 3949 \\ SIMP_TAC std_ss [list2sexp_def,MAP,isDot_def,CAR_def,CDR_def,mc_drop_thm] 3950 \\ SIMP_TAC (srw_ss()) [isSym_def,isQuote_def,CAR_def,CDR_def,LISP_TEST_EQ_T] 3951 \\ Q.PAT_ABBREV_TAC `lambda = Dot (Dot (Sym "LAMBDA") xx) yy` 3952 \\ Q.PAT_X_ASSUM `!x.bbb` MP_TAC 3953 \\ Q.PAT_X_ASSUM `!x.bbb` (STRIP_ASSUME_TAC o RW [] o Q.SPECL [`^COMPILE_LAM1::lambda::bool2sexp ret::a2sexp a::xs'`,`code`]) 3954 \\ `(\a. term2sexp a) = term2sexp` by FULL_SIMP_TAC std_ss [FUN_EQ_THM] 3955 \\ ASM_SIMP_TAC std_ss [] \\ REPEAT STRIP_TAC 3956 \\ FULL_SIMP_TAC std_ss [bool2sexp_def] 3957 \\ UNROLL_TAC 3958 \\ UNROLL_TAC 3959 \\ `CAR (CDR (CDR (CAR lambda))) = term2sexp x` by 3960 (Q.UNABBREV_TAC `lambda` \\ EVAL_TAC) 3961 \\ `CAR (CDR (CAR lambda)) = list2sexp (MAP Sym xs)` by 3962 (Q.UNABBREV_TAC `lambda` \\ EVAL_TAC) 3963 \\ ASM_SIMP_TAC std_ss [mc_length_thm,LENGTH_MAP,mc_drop_thm,mc_rev_append_thm] 3964 \\ Q.PAT_X_ASSUM `!xs.bbb` (MP_TAC o Q.SPECL [`^COMPILE_LAM2::lambda::bool2sexp ret::a2sexp a::xs'`,`WRITE_CODE code code1`]) 3965 \\ MATCH_MP_TAC IMP_IMP \\ STRIP_TAC THEN1 3966 (IMP_RES_TAC iLENGTH_thm 3967 \\ FULL_SIMP_TAC std_ss [code_ptr_WRITE_CODE,code_length_def]) 3968 \\ STRIP_TAC 3969 \\ ASM_SIMP_TAC std_ss [] 3970 \\ UNROLL_TAC 3971 \\ UNROLL_TAC 3972 \\ Cases_on `ret` 3973 \\ IMP_RES_TAC iLENGTH_thm 3974 \\ FULL_SIMP_TAC std_ss [bc_inv_def] 3975 \\ ASM_SIMP_TAC std_ss [code_ptr_WRITE_CODE,code_length_def,code_length_APPEND] 3976 \\ ASM_SIMP_TAC (srw_ss()) [a2sexp_def,MAP,a2sexp_aux_def,list2sexp_def, 3977 bool2sexp_def,mc_length_thm,LENGTH_MAP,WRITE_CODE_APPEND,APPEND_NIL, 3978 APPEND_ASSOC,getVal_def,AC ADD_COMM ADD_ASSOC,isVal_def] 3979 \\ METIS_TAC []) 3980 \\ STRIP_TAC (* Print *) THEN1 3981 (REPEAT STRIP_TAC \\ SIMP_TAC std_ss [Once mc_loop_unroll] 3982 \\ SIMP_TAC std_ss [Once mc_loop_unroll_pre] 3983 \\ SIMP_TAC std_ss [LET_DEF,SExp_11,SExp_distinct,term2sexp_def,func2sexp_def,isSym_def] 3984 \\ SIMP_TAC std_ss [list2sexp_def,MAP,isDot_def,CAR_def,CDR_def,mc_drop_thm] 3985 \\ SIMP_TAC (srw_ss()) [WRITE_CODE_APPEND,LISP_SUB_def,LISP_ADD_def,getVal_def, 3986 mc_cons_list_thm,isVal_def] \\ FULL_SIMP_TAC std_ss [APPEND] 3987 \\ Q.PAT_X_ASSUM `BC_return ret xxx = yyy` (ASSUME_TAC o GSYM) \\ END_PROOF_TAC) 3988 \\ STRIP_TAC (* Error *) THEN1 3989 (REPEAT STRIP_TAC \\ SIMP_TAC std_ss [Once mc_loop_unroll] 3990 \\ SIMP_TAC std_ss [Once mc_loop_unroll_pre] 3991 \\ SIMP_TAC std_ss [LET_DEF,SExp_11,SExp_distinct,term2sexp_def,func2sexp_def,isSym_def] 3992 \\ SIMP_TAC std_ss [list2sexp_def,MAP,isDot_def,CAR_def,CDR_def,mc_drop_thm] 3993 \\ SIMP_TAC (srw_ss()) [WRITE_CODE_APPEND,LISP_SUB_def,LISP_ADD_def,getVal_def, 3994 mc_cons_list_thm] \\ FULL_SIMP_TAC std_ss [APPEND] 3995 \\ Q.PAT_X_ASSUM `BC_return ret xxx = yyy` (ASSUME_TAC o GSYM) \\ END_PROOF_TAC) 3996 \\ STRIP_TAC (* Compile *) THEN1 3997 (REPEAT STRIP_TAC \\ SIMP_TAC std_ss [Once mc_loop_unroll] 3998 \\ SIMP_TAC std_ss [Once mc_loop_unroll_pre] 3999 \\ SIMP_TAC std_ss [LET_DEF,SExp_11,SExp_distinct,term2sexp_def,func2sexp_def,isSym_def,HD] 4000 \\ SIMP_TAC std_ss [list2sexp_def,MAP,isDot_def,CAR_def,CDR_def,mc_drop_thm] 4001 \\ Q.PAT_X_ASSUM `BC_return ret xxx = yyy` (ASSUME_TAC o GSYM) \\ END_PROOF_TAC) 4002 \\ STRIP_TAC (* Funcall *) THEN1 4003 (REPEAT STRIP_TAC \\ SIMP_TAC std_ss [Once mc_loop_unroll] 4004 \\ SIMP_TAC std_ss [Once mc_loop_unroll_pre] 4005 \\ SIMP_TAC std_ss [LET_DEF,SExp_11,SExp_distinct,term2sexp_def,func2sexp_def,isSym_def,HD] 4006 \\ SIMP_TAC std_ss [list2sexp_def,MAP,isDot_def,CAR_def,CDR_def,mc_drop_thm] 4007 \\ SIMP_TAC (srw_ss()) [WRITE_CODE_APPEND,LISP_SUB_def,LISP_ADD_def,getVal_def] 4008 \\ Q.PAT_X_ASSUM `BC_return ret xxx = yyy` (ASSUME_TAC o GSYM) \\ END_PROOF_TAC) 4009 \\ STRIP_TAC THEN1 4010 (UNROLL_TAC \\ SIMP_TAC std_ss [WRITE_CODE_NIL] \\ METIS_TAC []) 4011 \\ STRIP_TAC THEN1 4012 (UNROLL_TAC \\ FULL_SIMP_TAC std_ss [bool2sexp_def] 4013 \\ Q.PAT_X_ASSUM `!x.bbb` MP_TAC 4014 \\ Q.PAT_X_ASSUM `!x.bbb` (STRIP_ASSUME_TAC o RW [] o Q.SPECL [`Val 1::list2sexp (MAP term2sexp xs)::ys`,`code'`]) 4015 \\ ASM_SIMP_TAC std_ss [] \\ REPEAT STRIP_TAC \\ UNROLL_TAC 4016 \\ Q.PAT_X_ASSUM `!x.bbb` (STRIP_ASSUME_TAC o RW [] o Q.SPECL [`ys`,`WRITE_CODE code' code`]) 4017 \\ ASM_SIMP_TAC std_ss [WRITE_CODE_APPEND] 4018 \\ METIS_TAC []) 4019 (* only macros below *) 4020 \\ REVERSE (REPEAT STRIP_TAC) THEN 4021 (FULL_SIMP_TAC std_ss [term2sexp_def,func2sexp_def,prim2sym_def,APPEND] 4022 \\ UNROLL_TAC 4023 \\ FULL_SIMP_TAC (srw_ss()) [isQuote_def,isDot_def,CAR_def,CDR_def,isVal_def,LISP_TEST_EQ_T] 4024 \\ Q.PAT_ABBREV_TAC `foo1 = (BC_is_reserved_name xx = Sym "NIL")` 4025 \\ Q.PAT_ABBREV_TAC `foo2 = (BC_is_reserved_name xx = Val 0)` 4026 \\ `~foo1 /\ foo2` by 4027 (Q.UNABBREV_TAC `foo1` \\ Q.UNABBREV_TAC `foo2` \\ EVAL_TAC) 4028 \\ Q.UNABBREV_TAC `foo1` \\ Q.UNABBREV_TAC `foo2` 4029 \\ ASM_SIMP_TAC (srw_ss()) [mc_is_reserved_name_thm] 4030 \\ UNROLL_TAC 4031 \\ ASM_SIMP_TAC (srw_ss()) [mc_expand_macro_thm,BC_expand_macro_def,CAR_def,LET_DEF,HD,TL] 4032 \\ FULL_SIMP_TAC std_ss [list2sexp_def,CDR_def,CAR_def,ETA_AX,MAP,mc_map_car_thm,HD,TL] 4033 \\ FULL_SIMP_TAC std_ss [sexp2list_list2sexp,MAP_MAP_o,o_ABS_R,CAR_def,CDR_def,isDot_def] 4034 \\ FULL_SIMP_TAC (srw_ss()) [o_DEF] 4035 \\ FULL_SIMP_TAC std_ss [GSYM list2sexp_def] 4036 \\ FULL_SIMP_TAC std_ss [term2sexp_def,ETA_AX] 4037 \\ Q.PAT_X_ASSUM `!xs bbb. bbbb` (STRIP_ASSUME_TAC o RW [] o Q.SPECL [`xs`,`code'`]) 4038 \\ Q.EXISTS_TAC `exp2` 4039 \\ FULL_SIMP_TAC std_ss [] \\ NO_TAC)); 4040 4041val mc_loop_thm = 4042 mc_loop_lemma |> CONJUNCTS |> el 3 |> SIMP_RULE std_ss [PULL_FORALL_IMP] 4043 |> SPEC_ALL |> Q.INST [`xs`|->`^CONTINUE::xs`] |> RW1 [EQ_SYM_EQ] 4044 |> SIMP_RULE (srw_ss()) [LET_DEF,Once mc_loop_unroll] 4045 |> SIMP_RULE (srw_ss()) [LET_DEF,Once mc_loop_unroll_pre] |> RW1 [EQ_SYM_EQ] 4046 4047 4048(* reverse append with sfix *) 4049 4050val (_,mc_rev_sfix_append_def,mc_rev_sfix_append_pre_def) = compile "x64" `` 4051 mc_rev_sfix_append (x0,x1,x3) = 4052 if ~(isDot x0) then (let x0 = Sym "NIL" in let x1 = x0 in (x0,x1,x3)) else 4053 let x1 = x0 in 4054 let x0 = x3 in 4055 let x3 = CAR x1 in 4056 let x3 = SFIX x3 in 4057 let x3 = Dot x3 x0 in 4058 let x0 = CDR x1 in 4059 mc_rev_sfix_append (x0,x1,x3)``; 4060 4061val SFIX_THM = prove(``!x. SFIX x = Sym (getSym x)``,Cases \\ EVAL_TAC); 4062 4063val mc_rev_sfix_append_thm = prove( 4064 ``!x ys y. (mc_rev_sfix_append_pre (x,y,a2sexp ys)) /\ 4065 (mc_rev_sfix_append (x,y,a2sexp ys) = 4066 (Sym "NIL",Sym "NIL",a2sexp (MAP ssVAR (REVERSE (MAP getSym (sexp2list x))) ++ ys)))``, 4067 REVERSE Induct 4068 \\ SIMP_TAC std_ss [MAP,list2sexp_def,REVERSE_DEF,APPEND,LET_DEF, 4069 Once mc_rev_sfix_append_def,Once mc_rev_sfix_append_pre_def,isDot_def, 4070 CAR_def,CDR_def,SAFE_CAR_def,SAFE_CDR_def,sexp2list_def] \\ STRIP_TAC 4071 \\ POP_ASSUM (ASSUME_TAC o Q.SPEC `ssVAR (getSym x)::ys`) 4072 \\ FULL_SIMP_TAC std_ss [a2sexp_def,MAP,list2sexp_def,a2sexp_aux_def,SFIX_THM, 4073 REVERSE_APPEND,MAP_APPEND] 4074 \\ FULL_SIMP_TAC std_ss [GSYM APPEND_ASSOC,APPEND]); 4075 4076 4077(* top-level compile function *) 4078 4079val (mc_only_compile_spec,mc_only_compile_def,mc_only_compile_pre_def) = compile "x64" `` 4080 mc_only_compile (x0:SExp,x1,x2,x3:SExp,x4:SExp,x5,xs,xs1,code) = 4081 (* x0 - params *) 4082 (* x2 - term to compile *) 4083 (* x5 - bc_state_tree *) 4084 (* others are preserved *) 4085 let x3 = Sym "NIL" in 4086 let xs = x3::xs in 4087 let x4 = Sym "T" in 4088 let (x0,x1,x3) = mc_rev_sfix_append (x0,x1,x3) in 4089 let (x0,x1,x2,xs) = mc_sexp2sexp (x0,x1,x2,xs) in 4090 let x1 = Val 0 in 4091 let (x0,x1,x2,x3,x4,x5,xs,xs1,code) = mc_loop (x0,x1,x2,x3,x4,x5,xs,xs1,code) in 4092 let x2 = Sym "NIL" in 4093 let x3 = Sym "NIL" in 4094 (x0,x1,x2,x3,x4,x5,xs,xs1,code)``; 4095 4096val BC_EV_HILBERT_LEMMA = prove( 4097 ``bc_inv bc /\ BC_ev T (t,a,q,bc) y ==> ((@result. BC_ev T (t,a,q,bc) result) = y)``, 4098 METIS_TAC [BC_ev_DETERMINISTIC,bc_inv_def]); 4099 4100val INSERT_UNION_INSERT = store_thm("INSERT_UNION_INSERT", 4101 ``x INSERT (y UNION (z INSERT t)) = x INSERT z INSERT (y UNION t)``, 4102 SIMP_TAC std_ss [EXTENSION,IN_INSERT,IN_UNION] \\ METIS_TAC []); 4103 4104fun abbrev_code (th,def_name) = let 4105 fun mk_tuple [] = fail() 4106 | mk_tuple [x] = x 4107 | mk_tuple (x::xs) = pairSyntax.mk_pair(x,mk_tuple xs) 4108 val th = th |> RW [INSERT_UNION_INSERT,INSERT_UNION_EQ,UNION_EMPTY, 4109 GSYM UNION_ASSOC,UNION_IDEMPOT] 4110 val (_,_,c,_) = dest_spec (concl th) 4111 val input = mk_tuple (free_vars c) 4112 val ty = type_of (pairSyntax.mk_pabs(input,c)) 4113 val name = mk_var(def_name,ty) 4114 val def = Define [ANTIQUOTE (mk_eq(mk_comb(name,input),c))] 4115 val th = RW [GSYM def] th 4116 in th end; 4117 4118val RETURN_CLEAR_CACHE = let 4119 val th1 = Q.INST [`qs`|->`q::qs`,`cu`|->`NONE`] X64_LISP_STRENGTHEN_CODE 4120 val th2 = SPEC_FRAME_RULE (Q.INST [`ddd`|->`SOME T`,`cu`|->`NONE`] X64_LISP_RET) ``~zS`` 4121 val (_,_,_,q) = dest_spec (concl th1) 4122 val (_,p,_,_) = dest_spec (concl th2) 4123 val th3 = INST (fst (match_term p q)) th2 4124 val th = MATCH_MP SPEC_COMPOSE (CONJ th1 th3) |> RW [INSERT_UNION_EQ,UNION_EMPTY] 4125 in th end; 4126 4127val (_,_,code,_) = dest_spec (concl RETURN_CLEAR_CACHE) 4128 4129val SPEC_DISJ_INTRO = prove( 4130 ``!m p c q r. SPEC m p c q ==> SPEC m (p \/ r) c (q \/ r)``, 4131 REPEAT STRIP_TAC \\ MATCH_MP_TAC (GEN_ALL (RW [UNION_IDEMPOT] 4132 (Q.INST [`c1`|->`c`,`c2`|->`c`] (SPEC_ALL SPEC_MERGE)))) 4133 \\ Q.EXISTS_TAC `SEP_F` \\ ASM_SIMP_TAC std_ss [SEP_CLAUSES,SPEC_REFL]); 4134 4135val SPEC_PRE_DISJ_LEMMA = prove( 4136 ``SPEC m p c q /\ SPEC m p2 c q2 ==> 4137 SPEC m (p \/ p2) c (q \/ q2)``, 4138 SIMP_TAC std_ss [SPEC_PRE_DISJ] \\ REPEAT STRIP_TAC \\ IMP_RES_TAC SPEC_WEAKEN 4139 \\ REPEAT (POP_ASSUM (MP_TAC o Q.SPEC `q \/ q2`)) 4140 \\ FULL_SIMP_TAC std_ss [SEP_IMP_def,SEP_DISJ_def]); 4141 4142val X64_LISP_CODE_INTRO_RETURN_CLEAR_CACHE = prove( 4143 ``SPEC X64_MODEL pp cc 4144 (let (x0,x1,x2,x3,x4,x5,xs,xs1,code) = hoo in 4145 ~zS * zPC p * 4146 zLISP (a1,a2,sl,sl1,e,ex,cs,rbp,SOME F,NONE) 4147 (x0,x1,x2,x3,x4,x5,xs,xs1,io,xbp,q::qs,code,amnt,ok) \/ 4148 zLISP_FAIL (a1,a2,sl,sl1,e,ex,cs,rbp,SOME F,NONE)) ==> 4149 SPEC X64_MODEL pp (cc UNION ^code) 4150 (let (x0,x1,x2,x3,x4,x5,xs,xs1,code) = hoo in 4151 ~zS * zPC q * 4152 zLISP (a1,a2,sl,sl1,e,ex,cs,rbp,SOME T,NONE) 4153 (x0,x1,x2,x3,x4,x5,xs,xs1,io,xbp,qs,code,amnt,ok) \/ 4154 zLISP_FAIL (a1,a2,sl,sl1,e,ex,cs,rbp,SOME T,NONE))``, 4155 `?x0 x1 x2 x3 x4 x5 xs xs1 code. hoo = (x0,x1,x2,x3,x4,x5,xs,xs1,code)` by METIS_TAC [PAIR] 4156 \\ FULL_SIMP_TAC std_ss [LET_DEF] \\ REPEAT STRIP_TAC 4157 \\ IMP_RES_TAC (RW [GSYM AND_IMP_INTRO] SPEC_COMPOSE) 4158 \\ POP_ASSUM MATCH_MP_TAC 4159 \\ MATCH_MP_TAC SPEC_PRE_DISJ_LEMMA \\ STRIP_TAC 4160 THEN1 (SIMP_TAC (std_ss++star_ss) [] 4161 \\ METIS_TAC [SIMP_RULE (std_ss++star_ss) [] RETURN_CLEAR_CACHE]) 4162 \\ FULL_SIMP_TAC std_ss [zLISP_FAIL_def,SPEC_REFL]); 4163 4164val X64_LISP_COMPILE = save_thm("X64_LISP_COMPILE",let 4165 val th = MATCH_MP X64_LISP_CODE_INTRO_RETURN_CLEAR_CACHE 4166 (Q.INST [`qs`|->`q::qs`] mc_only_compile_spec) 4167 val ff = Q.INST [`ddd`|->`SOME F`,`cu`|->`NONE`] 4168 val jump = ff X64_LISP_CALL_EL8 4169 val def_name = "abbrev_code_for_compile" 4170 val th = abbrev_code (th,def_name) 4171 val th = SPEC_COMPOSE_RULE [ff X64_LISP_WEAKEN_CODE,ff X64_LISP_CALL_EL8,th] 4172 val th = RW [STAR_ASSOC] th 4173 val _ = add_compiled [th] 4174 in th end); 4175 4176 4177(* code for iCOMPILE -- stores function definition into bc_state, i.e. x5 *) 4178 4179val _ = let (* reload all primitive ops with SOME T for ddd *) 4180 val thms = DB.match [] ``SPEC X64_MODEL`` 4181 val thms = filter (can (find_term (can (match_term ``zLISP``))) o car o concl) (map (fst o snd) thms) 4182 val thms = map (Q.INST [`ddd`|->`SOME T`,`cu`|->`NONE`]) thms 4183 val _ = map (fn th => add_compiled [th] handle e => ()) thms 4184 in () end; 4185 4186val (_,mc_arg_length_def,mc_arg_length_pre_def) = compile "x64" `` 4187 mc_arg_length (x0,x1) = 4188 if ~(isDot x0) then let x0 = Sym "NIL" in (x0,x1) else 4189 let x0 = CDR x0 in 4190 let x1 = LISP_ADD x1 (Val 1) in 4191 mc_arg_length (x0,x1)`` 4192 4193val mc_arg_length_thm = prove( 4194 ``!x n. 4195 mc_arg_length_pre (x,Val n) /\ 4196 (mc_arg_length (x,Val n) = (Sym "NIL",Val (n + LENGTH (sexp2list x))))``, 4197 Induct \\ ASM_SIMP_TAC std_ss [sexp2list_def,Once mc_arg_length_def,isDot_def, 4198 LENGTH,CDR_def,LISP_ADD_def,getVal_def,Once mc_arg_length_pre_def,LET_DEF,isVal_def] 4199 \\ SIMP_TAC std_ss [AC ADD_ASSOC ADD_COMM,ADD1]); 4200 4201val (_,mc_store_fun_def,mc_store_fun_pre_def) = compile "x64" `` 4202 mc_store_fun (x0:SExp,x1:SExp,x3:SExp,x4:SExp,x5,code) = 4203 let x0 = x3 in 4204 let x1 = Val 0 in 4205 let (x0,x1) = mc_arg_length (x0,x1) in 4206 let x0 = Val (code_ptr code) in 4207 let x0 = Dot x0 x1 in 4208 let x1 = CDR x5 in 4209 let x0 = Dot x0 x1 in 4210 let x1 = x4 in 4211 let x1 = Dot x1 x0 in 4212 let x0 = CAR x5 in 4213 let x0 = Dot x0 x1 in 4214 let x5 = x0 in 4215 (x0,x1,x3,x4,x5,code)`` 4216 4217val list2sexp_11 = prove( 4218 ``!x y. (list2sexp x = list2sexp y) = (x = y)``, 4219 Induct \\ Cases_on `y` \\ EVAL_TAC \\ ASM_SIMP_TAC std_ss []) 4220 4221val mc_store_fun_thm = prove( 4222 ``bc_inv bc ==> 4223 ?y0 y1 bc2. 4224 mc_store_fun_pre (x0,x1,params,Sym fname,bc_state_tree bc,code) /\ 4225 (mc_store_fun (x0,x1,params,Sym fname,bc_state_tree bc,code) = 4226 (y0,y1,params,Sym fname,bc_state_tree bc2,code)) /\ 4227 (bc2 = BC_STORE_COMPILED bc fname (code_ptr code,LENGTH (sexp2list params))) /\ 4228 bc_inv bc2``, 4229 SIMP_TAC std_ss [mc_store_fun_def,mc_store_fun_pre_def,LET_DEF] 4230 \\ ASM_SIMP_TAC std_ss [mc_arg_length_thm,bc_state_tree_def,isDot_def,CAR_def,CDR_def] 4231 \\ FULL_SIMP_TAC (srw_ss()) [BC_STORE_COMPILED_def,bc_inv_def,const_tree_def] 4232 \\ FULL_SIMP_TAC std_ss [GSYM list2sexp_def,list2sexp_11,LENGTH,EVEN] 4233 \\ FULL_SIMP_TAC std_ss [flat_alist_def] 4234 \\ FULL_SIMP_TAC (srw_ss()) [BC_CODE_OK_def] \\ METIS_TAC []); 4235 4236val (_,mc_fun_exists_def,mc_fun_exists_pre_def) = compile "x64" `` 4237 mc_fun_exists (x0,x1,x4) = 4238 if ~(isDot x1) then (x0,x1,x4) else 4239 let x0 = CAR x1 in 4240 let x1 = CDR x1 in 4241 if x0 = x4 then 4242 let x1 = Sym "T" in 4243 (x0,x1,x4) 4244 else 4245 let x1 = CDR x1 in 4246 mc_fun_exists (x0,x1,x4)`` 4247 4248val mc_fun_exists_thm = prove( 4249 ``!xs y fc. ?y0. 4250 mc_fun_exists_pre (y,list2sexp (flat_alist xs),Sym fc) /\ 4251 (mc_fun_exists (y,list2sexp (flat_alist xs),Sym fc) = 4252 (y0,LISP_TEST (MEM fc (MAP FST xs)),Sym fc))``, 4253 Induct \\ SIMP_TAC std_ss [flat_alist_def,list2sexp_def,MAP,MEM] 4254 \\ ONCE_REWRITE_TAC [mc_fun_exists_def,mc_fun_exists_pre_def] 4255 \\ SIMP_TAC std_ss [isDot_def,LISP_TEST_def] 4256 \\ Cases_on `h` \\ Cases_on `r` \\ SIMP_TAC (srw_ss()) [isDot_def, 4257 LET_DEF,flat_alist_def,list2sexp_def,CAR_def,CDR_def, 4258 markerTheory.Abbrev_def] \\ REPEAT STRIP_TAC 4259 \\ Cases_on `q = fc` \\ FULL_SIMP_TAC std_ss [LISP_TEST_def]); 4260 4261val no_such_function_bool_def = Define ` 4262 no_such_function_bool = F`; 4263 4264val _ = let 4265 val thms = [SPEC_COMPOSE_RULE [X64_LISP_ERROR_11,X64_LISP_SET_OK_F]] 4266 val thms = map (RW [GSYM no_such_function_bool_def]) thms 4267 val thms = map (Q.INST [`ddd`|->`SOME T`,`cu`|->`NONE`]) thms 4268 val _ = map (fn th => add_compiled [th] handle e => ()) thms 4269 in () end; 4270 4271val (_,mc_check_exists_def,mc_check_exists_pre_def) = compile "x64" `` 4272 mc_check_exists (x0,x1,x4,ok:bool) = 4273 let (x0,x1,x4) = mc_fun_exists (x0,x1,x4) in 4274 if x1 = Sym "NIL" then (x0,x1,x4,ok) else 4275 let (x0,ok) = (no_such_function x0,no_such_function_bool) in 4276 (x0,x1,x4,ok)`` 4277 4278val FUN_LOOKUP_EQ_NONE = prove( 4279 ``!xs. (FUN_LOOKUP xs y = NONE) = ~(MEM y (MAP FST xs))``, 4280 Induct \\ FULL_SIMP_TAC std_ss [FUN_LOOKUP_def,MAP,MEM,FORALL_PROD] 4281 \\ SRW_TAC [] []); 4282 4283val mc_check_exists_thm = prove( 4284 ``!xs y fc ok. 4285 (FUN_LOOKUP xs fc = NONE) ==> 4286 ?y0. 4287 mc_check_exists_pre (y,list2sexp (flat_alist xs),Sym fc,ok) /\ 4288 (mc_check_exists (y,list2sexp (flat_alist xs),Sym fc,ok) = 4289 (y0,Sym "NIL",Sym fc,ok))``, 4290 SIMP_TAC std_ss [mc_check_exists_def,mc_check_exists_pre_def,FUN_LOOKUP_EQ_NONE] 4291 \\ REPEAT STRIP_TAC \\ STRIP_ASSUME_TAC (SPEC_ALL mc_fun_exists_thm) 4292 \\ FULL_SIMP_TAC std_ss [LET_DEF,LISP_TEST_def]); 4293 4294val mc_check_exists_thm_alt = prove( 4295 ``!xs y fc ok. 4296 ~(FUN_LOOKUP xs fc = NONE) ==> 4297 ?y0. 4298 mc_check_exists_pre (y,list2sexp (flat_alist xs),Sym fc,ok) /\ 4299 (mc_check_exists (y,list2sexp (flat_alist xs),Sym fc,ok) = 4300 (y0,Sym "T",Sym fc,F))``, 4301 SIMP_TAC std_ss [mc_check_exists_def,mc_check_exists_pre_def,FUN_LOOKUP_EQ_NONE] 4302 \\ REPEAT STRIP_TAC \\ STRIP_ASSUME_TAC (SPEC_ALL mc_fun_exists_thm) 4303 \\ FULL_SIMP_TAC (srw_ss()) [LET_DEF,LISP_TEST_def] \\ EVAL_TAC); 4304 4305val (mc_compile_inst_spec,mc_compile_inst_def,mc_compile_inst_pre_def) = compile "x64" `` 4306 mc_compile_inst (x0:SExp,x1,x2:SExp,x3:SExp,x4:SExp,x5,xs,xs1,code,ok) = 4307 (* take args off stack *) 4308 let x2 = x0 in (* body *) 4309 let x3 = HD xs in (* params *) 4310 let xs = TL xs in 4311 let x4 = HD xs in (* fname *) 4312 let x4 = SFIX x4 in 4313 let xs = TL xs in 4314 (* check that definition does not already exist *) 4315 let x1 = CDR x5 in 4316 let (x0,x1,x4,ok) = mc_check_exists (x0,x1,x4,ok) in 4317 if ~(x1 = Sym "NIL") then 4318 let x0 = Sym "NIL" in 4319 let x1 = Sym "NIL" in 4320 let x2 = Sym "NIL" in 4321 let x3 = Sym "NIL" in 4322 let x4 = Sym "NIL" in 4323 (x0,x1,x2,x3,x4,x5,xs,xs1,code,ok) 4324 else 4325 (* store definition *) 4326 let (x0,x1,x3,x4,x5,code) = mc_store_fun (x0,x1,x3,x4,x5,code) in 4327 (* compile *) 4328 let x0 = x3 in 4329 let (x0,x1,x2,x3,x4,x5,xs,xs1,code) = mc_only_compile (x0,x1,x2,x3,x4,x5,xs,xs1,code) in 4330 (* return nil *) 4331 let x0 = Sym "NIL" in 4332 (x0,x1,x2,x3,x4,x5,xs,xs1,code,ok)``; 4333 4334val APPEND_NORMAL_RET = prove( 4335 ``SPEC X64_MODEL pp cc 4336 (let (x0,x1,x2,x3,x4,x5,xs,xs1,code,ok) = hoo in 4337 ~zS * zPC d * zLISP (a1,a2,sl,sl1,e,ex,cs,rbp,ddd,cu) 4338 (x0,x1,x2,x3,x4,x5,xs,xs1,io,xbp,q::qs,code,amnt,ok) 4339 \/ zLISP_FAIL (a1,a2,sl,sl1,e,ex,cs,rbp,ddd,cu)) ==> 4340 SPEC X64_MODEL pp (cc UNION {(d,[0x48w; 0xC3w])}) 4341 (let (x0,x1,x2,x3,x4,x5,xs,xs1,code,ok) = hoo in 4342 ~zS * zPC q * zLISP (a1,a2,sl,sl1,e,ex,cs,rbp,ddd,cu) 4343 (x0,x1,x2,x3,x4,x5,xs,xs1,io,xbp,qs,code,amnt,ok) 4344 \/ zLISP_FAIL (a1,a2,sl,sl1,e,ex,cs,rbp,ddd,cu))``, 4345 REPEAT STRIP_TAC 4346 \\ `?x0 x1 x2 x3 x4 x5 xs xs1 code ok. hoo = (x0,x1,x2,x3,x4,x5,xs,xs1,code,ok)` by METIS_TAC [PAIR] 4347 \\ FULL_SIMP_TAC std_ss [LET_DEF] \\ POP_ASSUM (K ALL_TAC) 4348 \\ POP_ASSUM (fn th => MP_TAC (SPEC_COMPOSE_RULE [th,X64_LISP_RET])) 4349 \\ FULL_SIMP_TAC (std_ss++star_ss) []); 4350 4351val bc_state_tree_code_end = prove( 4352 ``bc_state_tree (bc with code_end := x) = bc_state_tree bc``, 4353 FULL_SIMP_TAC (srw_ss()) [bc_state_tree_def,const_tree_def]); 4354 4355val bc_state_tree_WRITE_BYTECODE = prove( 4356 ``!xs a bc. bc_state_tree (WRITE_BYTECODE bc a xs) = bc_state_tree bc``, 4357 Induct \\ FULL_SIMP_TAC std_ss [WRITE_BYTECODE_def] 4358 \\ FULL_SIMP_TAC (srw_ss()) [bc_state_tree_def,const_tree_def]); 4359 4360val WRITE_BYTECODE_code_end = store_thm("WRITE_BYTECODE_code_end", 4361 ``!xs a bc. ((WRITE_BYTECODE bc a xs).code_end = bc.code_end) /\ 4362 ((WRITE_BYTECODE bc a xs).instr_length = bc.instr_length) /\ 4363 ((WRITE_BYTECODE bc a xs).consts = bc.consts)``, 4364 Induct \\ FULL_SIMP_TAC (srw_ss()) [WRITE_BYTECODE_def]); 4365 4366val BC_CODE_OK_WRITE_BYTECODE_LEMMA = prove( 4367 ``!xs a bc x y. 4368 (WRITE_BYTECODE (bc with <|code := x; code_end := y|>) a xs).code = 4369 (WRITE_BYTECODE (bc with <|code := x|>) a xs).code``, 4370 Induct \\ ASM_SIMP_TAC (srw_ss()) [WRITE_BYTECODE_def]); 4371 4372val WRITE_CODE_EQ_WRITE_BYTECODE = store_thm("WRITE_CODE_EQ_WRITE_BYTECODE", 4373 ``!xs bc. 4374 (bc_length = bc.instr_length) ==> 4375 (WRITE_CODE (BC_CODE (bc.code,bc.code_end)) xs = 4376 BC_CODE ((WRITE_BYTECODE bc bc.code_end xs).code, 4377 bc.code_end + iLENGTH bc_length xs))``, 4378 Induct \\ FULL_SIMP_TAC (srw_ss()) [WRITE_BYTECODE_def,WRITE_CODE_def,iLENGTH_def] 4379 \\ REPEAT STRIP_TAC 4380 \\ Q.PAT_X_ASSUM `!bc.bbb` 4381 (MP_TAC o Q.SPEC `(bc with code_end := bc.code_end + bc_length h) 4382 with code := (bc.code_end =+ SOME h) bc.code`) 4383 \\ FULL_SIMP_TAC (srw_ss()) [ADD_ASSOC] \\ REPEAT STRIP_TAC 4384 \\ FULL_SIMP_TAC std_ss [BC_CODE_OK_WRITE_BYTECODE_LEMMA]); 4385 4386val bc_inv_WRITE_BYTECODE = prove( 4387 ``!xs bc. 4388 bc_inv bc ==> 4389 bc_inv 4390 (WRITE_BYTECODE bc bc.code_end xs with 4391 code_end := bc.code_end + iLENGTH bc.instr_length xs)``, 4392 Induct \\ SIMP_TAC std_ss [bc_inv_def] 4393 THEN1 (SIMP_TAC (srw_ss()) [WRITE_BYTECODE_def,iLENGTH_def,BC_CODE_OK_def] 4394 \\ METIS_TAC []) \\ FULL_SIMP_TAC (srw_ss()) [WRITE_BYTECODE_code_end] 4395 \\ SIMP_TAC std_ss [WRITE_BYTECODE_def,iLENGTH_def] \\ REPEAT STRIP_TAC 4396 \\ `bc_inv (WRITE_BYTECODE bc bc.code_end [h] with 4397 code_end := bc.code_end + iLENGTH bc.instr_length [h])` by 4398 (FULL_SIMP_TAC (srw_ss()) [BC_CODE_OK_def,WRITE_BYTECODE_def,iLENGTH_def, 4399 APPLY_UPDATE_THM,bc_inv_def] \\ REPEAT STRIP_TAC 4400 THEN1 (Cases_on `h'` \\ EVAL_TAC \\ Cases_on `l` \\ EVAL_TAC) 4401 THEN1 EVAL_TAC THEN1 EVAL_TAC 4402 \\ `0 < bc.instr_length h` by METIS_TAC [] 4403 \\ `bc.code_end <= i` by DECIDE_TAC \\ FULL_SIMP_TAC std_ss [] 4404 \\ `0 < bc_length h` by METIS_TAC [] \\ DECIDE_TAC) 4405 \\ RES_TAC \\ FULL_SIMP_TAC std_ss [bc_inv_def] 4406 \\ FULL_SIMP_TAC (srw_ss()) [WRITE_BYTECODE_code_end,WRITE_BYTECODE_def,iLENGTH_def,ADD_ASSOC] 4407 \\ FULL_SIMP_TAC (srw_ss()) [BC_CODE_OK_def,WRITE_BYTECODE_code_end] 4408 \\ FULL_SIMP_TAC std_ss [BC_CODE_OK_WRITE_BYTECODE_LEMMA] \\ METIS_TAC []); 4409 4410val mc_only_compile_lemma = prove( 4411 ``bc_inv bc /\ (BC_ev_fun (MAP getSym (sexp2list params),sexp2term body,bc) = (new_code,a2,q2,bc2)) ==> 4412 mc_only_compile_pre (params,x1,body,x3, 4413 x4,bc_state_tree bc,xs,bc.consts,BC_CODE (bc.code,bc.code_end)) /\ 4414 (mc_only_compile (params,x1,body,x3, 4415 x4,bc_state_tree bc,xs,bc.consts,BC_CODE (bc.code,bc.code_end)) = 4416 (Sym "NIL",Sym "NIL",Sym "NIL",Sym "NIL",Sym "T",bc_state_tree bc2, 4417 xs,bc2.consts,WRITE_CODE (BC_CODE (bc.code,bc.code_end)) new_code)) /\ 4418 bc_inv bc2``, 4419 SIMP_TAC std_ss [mc_only_compile_def,mc_only_compile_pre_def, 4420 LET_DEF,GSYM (EVAL ``a2sexp []``),mc_sexp2sexp_thm] 4421 \\ SIMP_TAC std_ss [sexp2sexp_thm] 4422 \\ Q.SPEC_TAC (`sexp2term body`,`bbody`) \\ STRIP_TAC 4423 \\ ASM_SIMP_TAC std_ss [mc_rev_sfix_append_thm,APPEND_NIL] 4424 \\ SIMP_TAC std_ss [EVAL ``a2sexp []``,BC_ev_fun_def] \\ STRIP_TAC 4425 \\ `BC_JUMPS_OK bc` by 4426 (FULL_SIMP_TAC std_ss [bc_inv_def,BC_JUMPS_OK_def] 4427 \\ EVAL_TAC \\ SIMP_TAC std_ss []) 4428 \\ Q.ABBREV_TAC `ps = MAP getSym (sexp2list params)` 4429 \\ `?y. BC_ev T (bbody,MAP ssVAR (REVERSE ps),bc.code_end,bc) y` by METIS_TAC [BC_ev_TOTAL,bc_inv_def] 4430 \\ IMP_RES_TAC BC_EV_HILBERT_LEMMA \\ FULL_SIMP_TAC std_ss [] 4431 \\ Q.PAT_X_ASSUM `y = xxx` (fn th => FULL_SIMP_TAC std_ss [th]) 4432 \\ IMP_RES_TAC (SIMP_RULE std_ss [code_ptr_def] 4433 (Q.INST [`code`|->`BC_CODE (bc.code,bc.code_end)`] mc_loop_thm)) 4434 \\ POP_ASSUM (STRIP_ASSUME_TAC o SPEC_ALL) 4435 \\ FULL_SIMP_TAC std_ss [bool2sexp_def]); 4436 4437val WRITE_BYTECODE_code = prove( 4438 ``!new_code bc bc3 a. 4439 (bc.code = bc3.code) /\ (bc.instr_length = bc3.instr_length) ==> 4440 ((WRITE_BYTECODE bc a new_code).code = 4441 (WRITE_BYTECODE bc3 a new_code).code)``, 4442 Induct \\ SIMP_TAC std_ss [WRITE_BYTECODE_def] \\ REPEAT STRIP_TAC 4443 \\ Q.ABBREV_TAC `bcA = (bc with code := (a =+ SOME h) bc3.code)` 4444 \\ Q.ABBREV_TAC `bc3A = (bc3 with code := (a =+ SOME h) bc3.code)` 4445 \\ `(bcA.code = bc3A.code) /\ (bcA.instr_length = bc3A.instr_length)` by 4446 (Q.UNABBREV_TAC `bc3A` \\ Q.UNABBREV_TAC `bcA` \\ FULL_SIMP_TAC (srw_ss()) []) 4447 \\ RES_TAC \\ ASM_SIMP_TAC std_ss []); 4448 4449val mc_only_compile_thm = prove( 4450 ``bc_inv bc ==> 4451 let bc2 = BC_ONLY_COMPILE (MAP getSym (sexp2list params),sexp2term body,bc) in 4452 mc_only_compile_pre (params,x1,body,x3, 4453 x4,bc_state_tree bc,xs,bc.consts,BC_CODE (bc.code,bc.code_end)) /\ 4454 (mc_only_compile (params,x1,body,x3, 4455 x4,bc_state_tree bc,xs,bc.consts,BC_CODE (bc.code,bc.code_end)) = 4456 (Sym "NIL",Sym "NIL",Sym "NIL",Sym "NIL",Sym "T",bc_state_tree bc2, 4457 xs,bc2.consts,BC_CODE (bc2.code,bc2.code_end))) /\ 4458 bc_inv bc2``, 4459 STRIP_TAC 4460 \\ Q.ABBREV_TAC `ps = MAP getSym (sexp2list params)` 4461 \\ `?new_code a2 q2 bc3. (BC_ev_fun (ps,sexp2term body,bc) = (new_code,a2,q2,bc3))` by METIS_TAC [PAIR] 4462 \\ Q.UNABBREV_TAC `ps` 4463 \\ IMP_RES_TAC mc_only_compile_lemma 4464 \\ FULL_SIMP_TAC std_ss [LET_DEF,BC_ONLY_COMPILE_def] 4465 \\ FULL_SIMP_TAC std_ss [bc_state_tree_WRITE_BYTECODE,bc_state_tree_code_end] 4466 \\ `bc_length = bc.instr_length` by METIS_TAC [bc_inv_def] 4467 \\ FULL_SIMP_TAC std_ss [WRITE_CODE_EQ_WRITE_BYTECODE] 4468 \\ `BC_JUMPS_OK bc` by 4469 (FULL_SIMP_TAC std_ss [bc_inv_def,BC_JUMPS_OK_def,BC_CODE_OK_def]) 4470 \\ Q.ABBREV_TAC `ps = MAP getSym (sexp2list params)` 4471 \\ `?y. BC_ev T (sexp2term body,MAP ssVAR (REVERSE ps),bc.code_end,bc) y` by METIS_TAC [BC_ev_TOTAL,bc_inv_def] 4472 \\ IMP_RES_TAC BC_ev_fun_CONSTS 4473 \\ IMP_RES_TAC bc_inv_WRITE_BYTECODE 4474 \\ FULL_SIMP_TAC (srw_ss()) [WRITE_BYTECODE_code_end] 4475 \\ MATCH_MP_TAC WRITE_BYTECODE_code \\ ASM_SIMP_TAC std_ss []) 4476 |> SIMP_RULE std_ss [LET_DEF]; 4477 4478val bc_inv_BC_ONLY_COMPILE = store_thm("bc_inv_BC_ONLY_COMPILE", 4479 ``bc_inv bc ==> bc_inv (BC_ONLY_COMPILE (MAP getSym (sexp2list params),sexp2term body,bc))``, 4480 ASM_SIMP_TAC std_ss [mc_only_compile_thm]); 4481 4482val mc_compile_inst_thm = prove( 4483 ``bc_inv bc /\ (FUN_LOOKUP bc.compiled (getSym fname) = NONE) ==> 4484 let bc5 = BC_COMPILE (getSym fname,MAP getSym (sexp2list params),sexp2term body,bc) in 4485 mc_compile_inst_pre (body,x1,x2,x3,x4,bc_state_tree bc, 4486 params::fname::xs,bc.consts,BC_CODE (bc.code,bc.code_end),ok) /\ 4487 (mc_compile_inst (body,x1,x2,x3,x4,bc_state_tree bc, 4488 params::fname::xs,bc.consts,BC_CODE (bc.code,bc.code_end),ok) = 4489 (Sym "NIL",Sym "NIL",Sym "NIL",Sym "NIL",Sym "T", 4490 bc_state_tree bc5,xs,bc5.consts,BC_CODE (bc5.code,bc5.code_end),ok)) /\ bc_inv bc5``, 4491 SIMP_TAC std_ss [LET_DEF,mc_compile_inst_def,mc_compile_inst_pre_def,HD,TL,SFIX_THM] \\ STRIP_TAC 4492 \\ IMP_RES_TAC mc_check_exists_thm \\ POP_ASSUM (STRIP_ASSUME_TAC o Q.SPECL [`body`,`ok`]) 4493 \\ ASM_SIMP_TAC std_ss [bc_state_tree_def,CDR_def,isDot_def] 4494 \\ STRIP_ASSUME_TAC (UNDISCH (Q.INST [`x0`|->`y0`,`x1`|->`Sym "NIL"`,`ff`|->`getSym fname`, 4495 `code`|->`BC_CODE (bc.code,bc.code_end)`] 4496 (Q.INST [`fname`|->`ff`] (SIMP_RULE std_ss [] mc_store_fun_thm)))) 4497 \\ FULL_SIMP_TAC std_ss [code_ptr_def,GSYM bc_state_tree_def,LENGTH_MAP] 4498 \\ FULL_SIMP_TAC std_ss [mc_only_compile_thm,NOT_CONS_NIL,LENGTH_MAP] 4499 \\ FULL_SIMP_TAC std_ss [BC_COMPILE_def,LET_DEF,LENGTH_MAP] 4500 \\ Q.PAT_ABBREV_TAC `bcA = BC_STORE_COMPILED bc (getSym fname) zzz` 4501 \\ `(bc.code = bcA.code) /\ (bc.code_end = bcA.code_end) /\ 4502 (bc.consts = bcA.consts) /\ bc_inv bcA` by 4503 (FULL_SIMP_TAC std_ss [bc_inv_def,BC_CODE_OK_def] \\ Q.UNABBREV_TAC `bcA` 4504 \\ FULL_SIMP_TAC (srw_ss()) [BC_STORE_COMPILED_def] \\ METIS_TAC []) 4505 \\ FULL_SIMP_TAC std_ss [mc_only_compile_thm,NOT_CONS_NIL,LENGTH_MAP]) 4506 |> SIMP_RULE std_ss [LET_DEF]; 4507 4508val bc_inv_BC_COMPILE = save_thm("bc_inv_BC_COMPILE", 4509 mc_compile_inst_thm |> UNDISCH |> CONJUNCT2 |> DISCH_ALL); 4510 4511val X64_LISP_COMPILE_AUX = let 4512 val th = MATCH_MP APPEND_NORMAL_RET (Q.INST [`qs`|->`q::qs`] mc_compile_inst_spec) 4513 val def_name = "abbrev_code_for_compile_inst" 4514 val th = abbrev_code (th,def_name) 4515 in th end 4516 4517val X64_LISP_COMPILE_INST = save_thm("X64_LISP_COMPILE_INST",let 4518 val th = X64_LISP_COMPILE_AUX 4519 val th = Q.INST [`x0`|->`body`,`x5`|->`bc_state_tree bc`, 4520 `xs`|->`params::fname::xs`, 4521 `xs1`|->`bc.consts`, 4522 `code`|->`BC_CODE (bc.code,bc.code_end)`] th 4523 |> DISCH ``bc_inv bc /\ (FUN_LOOKUP bc.compiled (getSym fname) = NONE)`` 4524 |> SIMP_RULE std_ss [mc_compile_inst_thm,LET_DEF,SEP_CLAUSES] 4525 |> RW [GSYM SPEC_MOVE_COND] 4526 in th end); 4527 4528val mc_compile_inst_thm_alt = prove( 4529 ``bc_inv bc /\ ~(FUN_LOOKUP bc.compiled (getSym fname) = NONE) ==> 4530 let bc5 = BC_FAIL bc in 4531 mc_compile_inst_pre (body,x1,x2,x3,x4,bc_state_tree bc, 4532 params::fname::xs,bc.consts,BC_CODE (bc.code,bc.code_end),ok) /\ 4533 (mc_compile_inst (body,x1,x2,x3,x4,bc_state_tree bc, 4534 params::fname::xs,bc.consts,BC_CODE (bc.code,bc.code_end),ok) = 4535 (Sym "NIL",Sym "NIL",Sym "NIL",Sym "NIL",Sym "NIL", 4536 bc_state_tree bc5,xs,bc5.consts,BC_CODE (bc5.code,bc5.code_end),F)) /\ bc_inv bc5``, 4537 SIMP_TAC std_ss [LET_DEF,mc_compile_inst_def,mc_compile_inst_pre_def,HD,TL,SFIX_THM] \\ STRIP_TAC 4538 \\ IMP_RES_TAC mc_check_exists_thm_alt 4539 \\ POP_ASSUM (STRIP_ASSUME_TAC o Q.SPECL [`body`,`ok`]) 4540 \\ FULL_SIMP_TAC (srw_ss()) [bc_state_tree_def,CDR_def,BC_FAIL_def,isDot_def] 4541 \\ FULL_SIMP_TAC (srw_ss()) [bc_inv_def,BC_CODE_OK_def] \\ METIS_TAC []) 4542 |> SIMP_RULE std_ss [LET_DEF]; 4543 4544val X64_LISP_COMPILE_INST_FAIL = save_thm("X64_LISP_COMPILE_INST_FAIL",let 4545 val th = X64_LISP_COMPILE_AUX 4546 val th = Q.INST [`x0`|->`body`,`x5`|->`bc_state_tree bc`, 4547 `xs`|->`params::fname::xs`, 4548 `xs1`|->`bc.consts`, 4549 `code`|->`BC_CODE (bc.code,bc.code_end)`] th 4550 |> DISCH ``bc_inv bc /\ ~(FUN_LOOKUP bc.compiled (getSym fname) = NONE)`` 4551 |> SIMP_RULE std_ss [mc_compile_inst_thm_alt,LET_DEF,SEP_CLAUSES] 4552 |> RW [GSYM SPEC_MOVE_COND] 4553 in th end); 4554 4555val (mc_compile_for_eval_spec,mc_compile_for_eval_def,mc_compile_for_eval_pre_def) = compile "x64" `` 4556 mc_compile_for_eval (x0:SExp,x1,x2:SExp,x3:SExp,x4:SExp,x5,xs,xs1,code) = 4557 (* exp to evaluate in x0 *) 4558 let x2 = x0 in 4559 (* push code ptr *) 4560 let x0 = Val (code_ptr code) in 4561 let xs = x0::xs in 4562 (* compile with no params *) 4563 let x0 = Sym "NIL"in 4564 let (x0,x1,x2,x3,x4,x5,xs,xs1,code) = mc_only_compile (x0,x1,x2,x3,x4,x5,xs,xs1,code) in 4565 let x0 = HD xs in 4566 let xs = TL xs in 4567 (* call generated code *) 4568 let x2 = x0 in 4569 let x0 = Sym "NIL"in 4570 (x0,x1,x2,x3,x4,x5,xs,xs1,code)``; 4571 4572val mc_compile_for_eval_thm = store_thm("mc_compile_for_eval_thm", 4573 ``bc_inv bc ==> 4574 let bc2 = BC_ONLY_COMPILE ([],sexp2term body,bc) in 4575 mc_compile_for_eval_pre 4576 (body,x1,x2,x3,x4, 4577 bc_state_tree bc,xs,bc.consts,BC_CODE (bc.code,bc.code_end)) /\ 4578 (mc_compile_for_eval 4579 (body,x1,x2,x3,x4, 4580 bc_state_tree bc,xs,bc.consts,BC_CODE (bc.code,bc.code_end)) = 4581 (Sym "NIL",Sym "NIL",Val bc.code_end,Sym "NIL",Sym "T",bc_state_tree bc2, 4582 xs,bc2.consts,BC_CODE (bc2.code,bc2.code_end))) /\ 4583 bc_inv bc2``, 4584 SIMP_TAC std_ss [mc_compile_for_eval_def,mc_compile_for_eval_pre_def, 4585 LET_DEF,GSYM list2sexp_def] \\ STRIP_TAC 4586 \\ IMP_RES_TAC (Q.INST [`params`|->`Sym "NIL"`] mc_only_compile_thm 4587 |> SIMP_RULE std_ss [sexp2list_def,MAP]) 4588 \\ FULL_SIMP_TAC std_ss [MAP,HD,TL] 4589 \\ FULL_SIMP_TAC std_ss [list2sexp_def,NOT_CONS_NIL,code_ptr_def,HD,TL]) 4590 |> SIMP_RULE std_ss [LET_DEF]; 4591 4592val X64_LISP_COMPILE_FOR_EVAL = save_thm("X64_LISP_COMPILE_FOR_EVAL",let 4593 val th = mc_compile_for_eval_spec 4594 val th = Q.INST [`x0`|->`body`,`x5`|->`bc_state_tree bc`, 4595 `xs1`|->`bc.consts`, 4596 `code`|->`BC_CODE (bc.code,bc.code_end)`] th 4597 |> SIMP_RULE std_ss [UNDISCH mc_compile_for_eval_thm,LET_DEF,SEP_CLAUSES] 4598 |> DISCH_ALL |> RW [GSYM SPEC_MOVE_COND] 4599 in th end); 4600 4601 4602(* reload all primitive ops with ddd as a variable *) 4603 4604val _ = let 4605 val thms = DB.match [] ``SPEC X64_MODEL`` 4606 val thms = filter (can (find_term (can (match_term ``zLISP``))) o car o concl) (map (fst o snd) thms) 4607 val _ = map (fn th => add_compiled [th] handle e => ()) thms 4608 in () end; 4609 4610 4611(* 4612(* btree lookup, i.e. const lookup *) 4613 4614val (_,mc_btree_lookup_def,mc_btree_lookup_pre_def) = compile "x64" `` 4615 mc_btree_lookup (x0,x1) = 4616 if x0 = Val 0 then let x0 = CAR x1 in let x1 = Sym "NIL" in (x0,x1) else 4617 if x0 = Val 1 then let x0 = CAR x1 in let x1 = Sym "NIL" in (x0,x1) else 4618 let x1 = CDR x1 in 4619 if EVEN (getVal x0) then 4620 let x0 = Val (getVal x0 DIV 2) in 4621 let x1 = CAR x1 in 4622 mc_btree_lookup (x0,x1) 4623 else 4624 let x0 = Val (getVal x0 DIV 2) in 4625 let x1 = CDR x1 in 4626 mc_btree_lookup (x0,x1)``; 4627 4628val mc_btree_lookup_thm = prove( 4629 ``!n xs. n < LENGTH xs ==> 4630 mc_btree_lookup_pre (Val (n+1),list2btree xs) /\ 4631 (mc_btree_lookup (Val (n+1),list2btree xs) = (EL n xs,Sym "NIL"))``, 4632 completeInduct_on `n` \\ NTAC 2 STRIP_TAC 4633 \\ Cases_on `n = 0` \\ ASM_SIMP_TAC std_ss [Once mc_btree_lookup_def,Once mc_btree_lookup_pre_def,LET_DEF] THEN1 4634 (Cases_on `xs` \\ FULL_SIMP_TAC std_ss [LENGTH] 4635 \\ SIMP_TAC std_ss [list2btree_def,CAR_def,EL,HD,isDot_def]) 4636 \\ `~(n + 1 < 2)` by DECIDE_TAC \\ ASM_SIMP_TAC std_ss [] 4637 \\ SIMP_TAC (srw_ss()) [EVEN,GSYM ADD1,getVal_def,isVal_def] 4638 \\ Cases_on `n` \\ FULL_SIMP_TAC std_ss [EVEN] 4639 \\ SIMP_TAC std_ss [ADD1,GSYM ADD_ASSOC] 4640 \\ SIMP_TAC std_ss [(SIMP_RULE std_ss [] (Q.SPEC `2` ADD_DIV_ADD_DIV)) 4641 |> RW1 [ADD_COMM] |> Q.SPEC `1` |> SIMP_RULE std_ss []] 4642 \\ SIMP_TAC std_ss [RW[ADD1]EL] 4643 \\ Cases_on `xs` \\ FULL_SIMP_TAC std_ss [LENGTH,TL] 4644 \\ SIMP_TAC std_ss [list2btree_def,CAR_def,EL,HD,CDR_def,isDot_def] 4645 \\ Cases_on `t = []` \\ FULL_SIMP_TAC std_ss [LENGTH,CDR_def,CAR_def,isDot_def] 4646 \\ `n' DIV 2 < SUC n'` by (ASM_SIMP_TAC std_ss [DIV_LT_X] \\ DECIDE_TAC) 4647 \\ IMP_RES_TAC DIV_LESS_LENGTH_SPLIT_LIST 4648 \\ Cases_on `EVEN n'` \\ FULL_SIMP_TAC std_ss [] 4649 \\ RES_TAC \\ ASM_SIMP_TAC std_ss [] 4650 \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] 4651 \\ ASM_SIMP_TAC std_ss [Once EL_SPLIT_LIST] \\ METIS_TAC []); 4652 4653val (mc_const_lookup_spec,mc_const_lookup_def,mc_const_lookup_pre_def) = compile "x64" `` 4654 mc_const_lookup (x0:SExp,x1:SExp,x5:SExp) = 4655 let x0 = LISP_ADD x0 (Val 1) in 4656 let x1 = CAR x5 in 4657 let x1 = CDR x1 in 4658 let (x0,x1) = mc_btree_lookup (x0,x1) in 4659 (x0,x1,x5)`` 4660 4661val mc_const_lookup_thm = prove( 4662 ``!n bc x1. 4663 n < LENGTH bc.consts ==> 4664 mc_const_lookup_pre (Val n,x1,bc_state_tree bc) /\ 4665 (mc_const_lookup (Val n,x1,bc_state_tree bc) = 4666 (EL n bc.consts,Sym "NIL",bc_state_tree bc))``, 4667 ASM_SIMP_TAC std_ss [mc_const_lookup_def,mc_const_lookup_pre_def,LET_DEF, 4668 isVal_def,LISP_ADD_def,getVal_def,bc_state_tree_def,CAR_def,isDot_def] 4669 \\ REPEAT STRIP_TAC \\ IMP_RES_TAC mc_btree_lookup_thm 4670 \\ ASM_SIMP_TAC std_ss [const_tree_def,isDot_def,CDR_def]); 4671 4672val X64_BYTECODE_LOOKUP = save_thm("X64_BYTECODE_LOOKUP", 4673 mc_const_lookup_spec 4674 |> Q.INST [`x0`|->`Val n`,`x5`|->`bc_state_tree bc`] 4675 |> DISCH ``n < LENGTH bc.consts`` 4676 |> SIMP_RULE std_ss [mc_const_lookup_thm,LET_DEF,SEP_CLAUSES] 4677 |> RW [GSYM SPEC_MOVE_COND]); 4678*) 4679 4680 4681(* implementation of iCALL_SYM (and iJUMP_SYM) *) 4682 4683val (_,mc_fundef_lookup_def,mc_fundef_lookup_pre_def) = compile "x64" `` 4684 mc_fundef_lookup (x0,x1,x2,x3) = 4685 if ~(isDot x1) then (x0,x1,x2,x3) else 4686 let x0 = CAR x1 in 4687 let x1 = CDR x1 in 4688 if x0 = x2 then 4689 let x1 = CAR x1 in 4690 let x0 = CDR x1 in 4691 let x1 = CAR x1 in 4692 if x0 = x3 then (x0,x1,x2,x3) else 4693 let x1 = Sym "NIL" in 4694 (x0,x1,x2,x3) 4695 else 4696 let x1 = CDR x1 in 4697 mc_fundef_lookup (x0,x1,x2,x3)`` 4698 4699val (mc_fundef_lookup_full_spec,mc_fundef_lookup_full_def,mc_fundef_lookup_full_pre_def) = compile "x64" `` 4700 mc_fundef_lookup_full (x0,x1:SExp,x2,x3,x5,(xs:SExp list),io) = 4701 let x1 = CDR x5 in 4702 let x2 = x0 in 4703 let x3 = HD xs in 4704 let xs = TL xs in 4705 let (x0,x1,x2,x3) = mc_fundef_lookup (x0,x1,x2,x3) in 4706 let x0 = HD xs in 4707 let xs = TL xs in 4708 let x2 = x1 in 4709 if isVal x1 then (x0,x1,x2,x3,x5,xs,io) else 4710 let x0 = x2 in 4711 let io = IO_WRITE io (sexp2string x0) in 4712 let io = IO_WRITE io "\n" in 4713 let x0 = no_such_function x0 in 4714 (x0,x1,x2,x3,x5,xs,io)`` 4715 4716val mc_fundef_lookup_thm = prove( 4717 ``!xs y fc. 4718 (FUN_LOOKUP xs fc = SOME (i,m)) ==> 4719 ?y0. 4720 mc_fundef_lookup_pre (y,list2sexp (flat_alist xs),Sym fc,Val k) /\ 4721 (mc_fundef_lookup (y,list2sexp (flat_alist xs),Sym fc,Val k) = 4722 (y0,if k = m then Val i else Sym "NIL",Sym fc,Val k))``, 4723 Induct \\ SIMP_TAC std_ss [flat_alist_def,list2sexp_def] 4724 \\ ONCE_REWRITE_TAC [mc_fundef_lookup_def,mc_fundef_lookup_pre_def] 4725 \\ SIMP_TAC std_ss [isDot_def,FUN_LOOKUP_def,lookup_result_def] 4726 \\ Cases_on `h` \\ Cases_on `r` \\ SIMP_TAC (srw_ss()) [isDot_def,FUN_LOOKUP_def, 4727 lookup_result_def,LET_DEF,flat_alist_def,list2sexp_def,CAR_def,CDR_def, 4728 markerTheory.Abbrev_def] \\ REPEAT STRIP_TAC 4729 \\ Cases_on `q = fc` \\ FULL_SIMP_TAC std_ss [] \\ METIS_TAC []); 4730 4731val mc_fundef_lookup_full_thm = prove( 4732 ``bc_inv bc /\ (FUN_LOOKUP bc.compiled fc = SOME (i,m)) ==> 4733 mc_fundef_lookup_full_pre (Sym fc,x1,x2,x3,bc_state_tree bc,Val m::x::xs,io) /\ 4734 (mc_fundef_lookup_full (Sym fc,x1,x2,x3,bc_state_tree bc,Val m::x::xs,io) = 4735 (x,Val i,Val i,Val m,bc_state_tree bc,xs,io))``, 4736 SIMP_TAC std_ss [mc_fundef_lookup_full_def,mc_fundef_lookup_full_pre_def,LET_DEF,TL,HD] 4737 \\ REPEAT STRIP_TAC \\ IMP_RES_TAC mc_fundef_lookup_thm 4738 \\ POP_ASSUM (STRIP_ASSUME_TAC o Q.SPECL [`Sym fc`,`m`]) 4739 \\ FULL_SIMP_TAC std_ss [bc_state_tree_def,isDot_def,CDR_def,NOT_CONS_NIL,isVal_def]); 4740 4741val X64_BYTECODE_CALL_SYM = save_thm("X64_BYTECODE_CALL_SYM", 4742 mc_fundef_lookup_full_spec 4743 |> Q.INST [`x0`|->`Sym fc`,`x5`|->`bc_state_tree bc`,`xs`|->`Val m::x::xs`] 4744 |> DISCH ``bc_inv bc /\ (FUN_LOOKUP bc.compiled fc = SOME (i,m))`` 4745 |> SIMP_RULE std_ss [mc_fundef_lookup_full_thm] 4746 |> UNDISCH 4747 |> CONV_RULE (REWRITE_CONV [UNDISCH mc_fundef_lookup_full_thm]) 4748 |> SIMP_RULE std_ss [LET_DEF] 4749 |> DISCH_ALL |> SIMP_RULE (std_ss++sep_cond_ss) [GSYM SPEC_MOVE_COND] 4750 |> (fn th => SPEC_COMPOSE_RULE [th,X64_LISP_JUMP_TO_CODE]) 4751 |> SIMP_RULE std_ss [isVal_def,getVal_def,SEP_CLAUSES]); 4752 4753val X64_BYTECODE_JUMP_SYM = save_thm("X64_BYTECODE_JUMP_SYM", 4754 mc_fundef_lookup_full_spec 4755 |> Q.INST [`x0`|->`Sym fc`,`x5`|->`bc_state_tree bc`,`xs`|->`Val m::x::xs`] 4756 |> DISCH ``bc_inv bc /\ (FUN_LOOKUP bc.compiled fc = SOME (i,m))`` 4757 |> SIMP_RULE std_ss [mc_fundef_lookup_full_thm] 4758 |> UNDISCH 4759 |> CONV_RULE (REWRITE_CONV [UNDISCH mc_fundef_lookup_full_thm]) 4760 |> SIMP_RULE std_ss [LET_DEF] 4761 |> DISCH_ALL |> SIMP_RULE (std_ss++sep_cond_ss) [GSYM SPEC_MOVE_COND] 4762 |> (fn th => SPEC_COMPOSE_RULE [th,X64_LISP_JUMP_TO_CODE_NO_RET]) 4763 |> SIMP_RULE std_ss [isVal_def,getVal_def,SEP_CLAUSES]); 4764 4765val _ = export_theory(); 4766