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