#|

 Copyright (C) 1994 by Computational Logic, Inc.  All Rights Reserved.

 This script is hereby placed in the public domain, and therefore unlimited
 editing and redistribution is permitted.

 NO WARRANTY

 Computational Logic, Inc. PROVIDES ABSOLUTELY NO WARRANTY.  THE EVENT SCRIPT
 IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED,
 INCLUDING, BUT NOT LIMITED TO, ANY IMPLIED WARRANTIES OF MERCHANTABILITY AND
 FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND
 PERFORMANCE OF THE SCRIPT IS WITH YOU.  SHOULD THE SCRIPT PROVE DEFECTIVE, YOU
 ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.

 IN NO EVENT WILL Computational Logic, Inc. BE LIABLE TO YOU FOR ANY DAMAGES,
 ANY LOST PROFITS, LOST MONIES, OR OTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL
 DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THIS SCRIPT (INCLUDING BUT
 NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES
 SUSTAINED BY THIRD PARTIES), EVEN IF YOU HAVE ADVISED US OF THE POSSIBILITY OF
 SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY.

|#

; ------------------------------------------------------------
; was lr-eval5-1.events
; ------------------------------------------------------------

(note-lib "app-c-d-e" t)

(prove-lemma axiom-53 (rewrite)
  (implies (subrp fn) (equal (formals fn) f)))

(disable proper-p-statep-restructuring)

;; Function for testing s->r
(defn CHANGE-ELEMENTS (list)
  (if (listp list)
      (if (truep (car list))
	  (cons (false) (change-elements (cdr list)))
	  (cons (true) (change-elements (cdr list))))
      (if (truep list) (false) (true))))

(disable deposit)
(disable fetch)

(disable add-addr)
(disable sub-addr)
(disable offset)
(disable area-name)

(disable errorp)

(disable p-current-program)

;; The following is inspired by the lemma length-put of Piton.
;; Now in Piton-basis  A. Flatau  8-Oct-1990
;(prove-lemma MY-LENGTH-PUT (rewrite)
;  (equal (length (put val n lst))
;	 (if (lessp n (length lst))
;	     (length lst)
;	     (add1 n)))
;  ((enable put)))
;
;(disable my-length-put)

;; This is similar to the lemma GET-PUT from Piton, but for the commented
;; out hypothesis.
(prove-lemma MY-GET-PUT (rewrite)
  (implies (and (numberp k)
		(numberp n)
		;(lessp n (length lst))
		)
	   (equal (get k (put val n lst))
		  (if (equal k n) val (get k lst))))
  ((enable get-cons get put get-anything-nil)))

(disable my-get-put)

(prove-lemma LISTP-CDR-P-FRAME (rewrite)
  (listp (cdr (p-frame bindings ret-pc)))
  ((enable p-frame)))

(prove-lemma EQUAL-CDDR-P-FRAME-NIL (rewrite)
  (equal (cddr (p-frame bindings ret-pc)) nil)
  ((enable p-frame)))

#||
;; The following is used to test handling of temp variables
(defn FOO (state name)
  (let ((prog (app name state)))
    (cons state (cons (car prog) (cons (cadr prog) (caddr prog))))))

;(setq ss
;      (logic->s '(change-elements (cons '*1*true (app x y)))
;		 '((x . (*1*true *1*true . *1*false))
;		   (y . (*1*true . *1*false)))
;		  '(change-elements app)))
;(setq lrs (s->lr ss 'main 50 50 50 32))
;(setq foop
;      '(FOO (STATE NAME)
;	    ((APP NAME STATE)
;	     (CDR ((TEMP-FETCH) (APP NAME STATE))))
;	    (CONS STATE
;		  (CONS (CAR ((TEMP-EVAL) (APP NAME STATE)))
;			(CONS (CAR ((TEMP-EVAL)
;				    (CDR ((TEMP-FETCH) (APP NAME STATE)))))
;			      (CAR (CDR ((TEMP-FETCH)
;					 (CDR ((temp-fetch)
;					       (APP NAME STATE)))))))))))
;
;(setq ss1 (s-state (s-expr ss)
;		   (s-params ss)
;		   (s-temps ss)
;		   (s-consts ss)
;		   (put-assoc (cdr foop) 'foo (s-progs ss))
;		   'run))
;
;(setq ss2 (s-state '(FOO (CHANGE-ELEMENTS (CONS '(ADDR (heap . 4))
;						(APP ((temp-eval) X) Y)))
;			 ((temp-fetch) X))
;		   (s-params ss1)
;		   (make-temps-entries '(x))
;		   (s-consts ss1)
;		   (s-progs ss1)
;		   'run))
||#

(defn S-L-EVAL-EQUIV-HYPS (flag s c)
  (and (s-good-statep s c)
       (good-posp flag (s-pos s) (s-body (s-prog s)))
       (equal (s-err-flag (s-eval flag s c)) 'run)))

(defn S-L-EVAL-FLAG-RUN-HYPS (flag s c)
  (and (s-good-statep s c)
       (s-all-temps-setp flag
			 (if (equal flag 'list)
			     (s-expr-list s)
			     (s-expr s))
			 (temp-alist-to-set (s-temps s)))
       (s-all-progs-temps-setp (s-progs s))
       (if (equal flag 'list)
	   (not (member f (l-eval flag
				  (s-expand-temps flag (s-expr-list s))
				  (s-params s)
				  c)))
	   (l-eval flag
		   (s-expand-temps flag (s-expr s))
		   (s-params s)
		   c))
       (s-check-temps-setp (s-temps s))))


;; ***** The LR-level (R for Resource, L for logic).  *****
;; We used to have an LR-STATE shell.  Now we just use a P-STATE shell.
;; However we refer to LR-STATES which are P-STATEs with LR level programs.
;; The function LR->P compiles an LR-STATE to a Piton state, by compiling
;; the programs and converting the P-PC to a Piton PC.
;; We use P-STATE shells instead of LR-STATE shell because we used to have
;; define functions analogous to P-OBJECTP (and functions that called
;; P-OBJECTP) that took LR-STATES or parts thereof.

;; We use the Piton notion of a PROPER state.  It should be the case that
;; all the LR-STATEs we are interested in are PROPER-P-STATEPs after we
;; apply LR->P to them.

;; An LR PC object is a combination of a Piton PC object and an S level
;; S-PNAME and S-POS.  The translation of (s-pname s) and (s-pos s) from
;; the S level is: (TAG 'PC (CONS (S-PNAME S) (S-POS S)))

;; Each element of P-PROG-SEGMENT is a program.  A program is a list
;; of the form:
;;
;; (name (formal1 formal2 ... formaln)
;;       ((temp1 init1)
;;        ...
;;        (tempk initk))
;;       body)
;;
;; The name and each formal and temp is a symbol.  The initial values
;; of the temps are tagged values.  Body is a form similar to that for
;; the S level, but temporary expressions have been replaced the name of
;; a temporary variable added to them
;; e.g. ((S-TEMP-EVAL) <expr>) -> ((S-TEMP-EVAL) <expr> <var>).
;; In the case of (S-TEMP-FETCH) <expr> is never used but we put it
;; in for consistency and so it is easier to convert back to s-states.
;; Also the numbers in the S level quote constructs have been replaced
;; by data-addresses that should contain pointers to the appropriate
;; structure in the heap.

;; Roughly speaking, a function application of FUN binds the formals to
;; the top n elements of the temp-stk (removing them from that stack and
;; building a ctrl-stk frame), binds the temps to the corresponding tagged
;; values (also in the ctrl-stk frame), and executes each instruction.

;; Producing LR-code from S-code.

(defn LR-UNDEFINED-TAG () 0)		; Used in node to indicate
					; uninitialized temporary variable
(defn LR-INIT-TAG () 1)			; Used in initial nodes that have
					; not been used
(defn LR-FALSE-TAG () 2)
(defn LR-TRUE-TAG  () 3)
(defn LR-ADD1-TAG  () 4)
(defn LR-CONS-TAG  () 5)
(defn LR-PACK-TAG  () 6)
(defn LR-MINUS-TAG  () 7)

(defn LR-HEAP-NAME () 'heap)

(defn LR-NODE-SIZE () 4)

(defn LR-UNDEF-ADDR () (tag 'addr '(heap . 0)))
(defn LR-F-ADDR () (add-addr (lr-undef-addr) (lr-node-size)))
(defn LR-T-ADDR () (add-addr (lr-F-addr) (lr-node-size)))
(defn LR-0-ADDR () (add-addr (lr-T-addr) (lr-node-size)))

(defn LR-FP-ADDR () (tag 'addr '(free-ptr . 0)))
(defn LR-ANSWER-ADDR () (tag 'addr '(answer . 0)))

(defn LR-FETCH-FP (data-seg)
  (fetch (lr-FP-addr) data-seg))

(defn LR-MINIMUM-HEAP-SIZE ()
  (offset (add-addr (lr-0-addr) (lr-node-size))))

;; The heap is a (presumably large) Piton data area.  It contains Nodes
;; which are four words.  One word is for the tag, one for the reference
;; count, and two for the contents.  Some data-types only require one word
;; for the contents (e.g. NUMBERPs) in that case one word is wasted.  Some
;; (user-defined) data-types require more than two words. In this case the
;; second word is a pointer to another node.  This contains up to three
;; words of data, the fourth word (if the data type needs more that four
;; words) is used to link another node with the same format.  The heap is
;; the Piton data area named HEAP.

;; LR-NEW-NODE returns another node to be stuck in memory
(defn LR-NEW-NODE (tag ref-count value1 value2)
  (list tag ref-count value1 value2))

(defn LR-REF-COUNT-OFFSET () 1)

(defn LR-CAR-OFFSET () 2)
(defn LR-CDR-OFFSET () 3)
(defn LR-UNPACK-OFFSET () 2)
(defn LR-UNBOX-NAT-OFFSET () 2)
(defn LR-NEGATIVE-GUTS-OFFSET () 2)

(defn LR-BOUNDARY-OFFSETP (offset)
  (equal (remainder offset (lr-node-size)) 0))

(defn LR-BOUNDARY-NODEP (node)
  (lr-boundary-offsetp (offset node)))

(defn LR-NODEP (addr data-seg)
  (and (equal (type addr) 'addr)
       (equal (cddr addr) nil)
       (listp addr)
       (adpp (untag addr) data-seg)
       (lr-boundary-nodep addr)
       (equal (area-name addr) (lr-heap-name))))

;; LR-GOOD-POINTERP checks that an addr is a node and its ref count field
;; is a natural.
(defn LR-GOOD-POINTERP (addr data-seg)
  (and (lr-nodep addr data-seg)
       (equal (type (fetch (add-addr addr (lr-ref-count-offset))
			   data-seg))
	      'nat)))

(defn LR-EXPR (p)
  (cur-expr (offset (p-pc p)) (program-body (p-current-program p))))

(disable lr-expr)

(defn LR-EXPR-LIST (p)
  (restn (car (last (offset (p-pc p))))
	 (cur-expr (butlast (offset (p-pc p)))
		   (program-body (p-current-program p)))))

(disable lr-expr-list)

;;; Debugging Stuff.
(defn MARK-INSTR (instruction-list n)
  (if (zerop n)
      (cons (list 'pc-> (car instruction-list)) (cdr instruction-list))
      (cons (car instruction-list)
	    (mark-instr (cdr instruction-list) (sub1 n)))))

(defn FIX-PROGRAM-SEGMENT (programs pc)
  (if (listp programs)
      (let ((prog (car programs)))
	(if (equal (car prog) (area-name pc))
	    (cons (append (list (car prog)
				(cadr prog)
				(caddr prog))
			  (mark-instr (program-body prog) (offset pc)))
		  (fix-program-segment (cdr programs) pc))
	    (cons (car prog) (fix-program-segment (cdr programs) pc))))
      nil))

(defn FIX-DATA-SEGMENT (data-segment)
  (put-value (append (firstn (offset (lr-fetch-fp data-segment))
			     (value (lr-heap-name) data-segment))
		     (difference (length (value (lr-heap-name)
						data-segment))
				 (offset (lr-fetch-fp data-segment))))
	     (lr-heap-name)
	      data-segment))

(defn FIND-NON-PROPER-INSTR (lst name p)
  (if (listp lst)
      (if (and (legal-labelp (car lst))
	       (proper-p-instructionp (unlabel (car lst)) name p))
	  (find-non-proper-instr (cdr lst) name p)
	  (car lst))
      nil))


(defn FIND-NON-PROPER-PROGRAMS (progs p)
  (if (listp progs)
      (if (proper-p-programp (car progs) p)
	  (cons (name (car progs)) (find-non-proper-programs (cdr progs) p))
	  (cons (list 'not
		       (name (car progs))
		       (find-non-proper-instr (program-body (car progs))
					      (name (car progs))
					      p))
		(find-non-proper-programs (cdr progs) p)))
      nil))

(defn PPS (state)
  (list 'p-state
	 (p-pc state)
	 (p-ctrl-stk state)
	 (p-temp-stk state)
	 (let ((p (p-current-program state)))
	   (append (list (name p) (formal-vars p) (temp-var-dcls p))
		   (mark-instr (program-body p) (offset (p-pc state)))))
	 (fix-data-segment (p-data-segment state))
	 (p-psw state)))

(defn LR-NODIFY-TAG (tag)
  (cond ((equal (untag tag) (lr-false-tag)) 'false)
	((equal (untag tag) (lr-true-tag)) 'true)
	((equal (untag tag) (lr-add1-tag)) 'add1)
	((equal (untag tag) (lr-cons-tag)) 'cons)
	((equal (untag tag) (lr-pack-tag)) 'pack)
	(t 'unknown)))
  
(defn LR-NODIFY (number nodes final)
  (if (listp nodes)
      (cons (list 'node
		   number
		   (lr-nodify-tag (car nodes))
		   (caddr nodes)
		   (cadddr nodes))
	    (lr-nodify (plus number (lr-node-size)) (cddddr nodes) final))
      final))

(defn LR-FIX-DATA-SEGMENT (data-seg)
  (put-value (lr-nodify 0
			(firstn (offset (lr-fetch-fp data-seg))
				(value (lr-heap-name) data-seg))
			(difference (length (value (lr-heap-name) data-seg))
				    (offset (lr-fetch-fp data-seg))))
	     (lr-heap-name)
	     data-seg))

(defn LRPS (state)
  (p-state (p-pc state)
	   (p-ctrl-stk state)
	   (p-temp-stk state)
	   (p-prog-segment state)
	   (lr-fix-data-segment (p-data-segment state))
	   (p-max-ctrl-stk-size state)
	   (p-max-temp-stk-size state)
	   (p-word-size state)
	   (p-psw state)))


;; Returns the object denoted by addr in the heap.
(defn LR-ABS (addr data-seg n)
  (if (zerop n)
      nil
      (let ((tag (untag (fetch addr data-seg))))
	(cond ((equal tag (lr-false-tag)) f)
	      ((equal tag (lr-true-tag)) t)
	      ((equal tag (lr-add1-tag))
	       (untag (fetch (add-addr addr (lr-unbox-nat-offset))
			     data-seg)))
	      ((equal tag (lr-cons-tag))
	       (cons (lr-abs (fetch (add-addr addr (lr-car-offset))
				    data-seg)
			     data-seg
			     (sub1 n))
		     (lr-abs (fetch (add-addr addr (lr-cdr-offset))
				    data-seg)
			     data-seg
			     (sub1 n))))
	       ((equal tag (lr-pack-tag))
		(pack (lr-abs (fetch (add-addr addr (lr-unpack-offset))
				     data-seg)
			      data-seg
			      (sub1 n))))
	       (t			; (EQUAL TAG (LR-MINUS-TAG))
		(minus (untag (fetch (add-addr addr
					       (lr-negative-guts-offset))
				     data-seg))))))))


(defn TOP-STK (p-or-p-state)
  (let ((temp-stk (if (p-statep p-or-p-state)
		      (p-temp-stk p-or-p-state)
		      (p-temp-stk p-or-p-state)))
	(data-segment (if (p-statep p-or-p-state)
			  (p-data-segment p-or-p-state)
			  (p-data-segment p-or-p-state))))
    (lr-abs (top temp-stk) data-segment 1000)))

;; This is accessed by the Piton accessors: NAME, FORMAL-VARS, TEMP-VAR-DCLS
;; and PROGRAM-BODY.  Also LOCAL-VARS.
(defn LR-MAKE-PROGRAM (name formals temps body)
  (cons name (cons formals (cons temps body))))

#||
stolen from matt kaufmann's code for gensym, but modified to probably be
less useful but simplier.

here is a sequence of events for generating a new symbol.
the main function is near the end, and is called gensym.
gensym returns a pair the new symbol and the next number list to try.
here are some examples:

>(r-loop)

trace mode: off   abbreviated output mode:  on
type ? for help.
*(gensym (unpack 'a*) '(49) '(a*0 a*1 a*2 a*3))
 '(a*4 53)
*(gensym (unpack 'a*) '(53) '(a*0 a*1 a*2 a*3 a*4))
 '(a*5 54)
*(gensym (unpack 'a*) '(50) '(a*2))
 '(a*3 52)
*(gensym (unpack 'a*) '(50) '(a*0))
 '(a*2 51)
*(gensym (unpack 'a) '(48) '(a*0 a*1))
 '(a0 49)
*(gensym (unpack 'a) '(48) '(a b))
 '(a0 49)
*(gensym (unpack 'a*2*) '(51) '(a*2*3))
 '(a*2*4 53)
*(gensym (unpack 'b*) '(50) '(a*0 a*1 a*2 a*3))
 '(b*2 51)
*ok
exiting r-loop.
nil

||#


(defn ASCII-0 () 48)
(defn ASCII-1 () 49)
(defn ASCII-9 () 57)

(defn ASCII-DASH () 45)

(defn LIST-ASCII-0 () (list (ascii-0)))
(defn LIST-ASCII-1 () (list (ascii-1)))

(defn INCREMENT-NUMLIST (numlist)
  ;; NUMLIST is a list of Ascii codes of digits, units digit first
  (if (listp numlist)
      (if (equal (car numlist) (ascii-9))
	  (cons (ascii-0) (increment-numlist (cdr numlist)))
	  (cons (add1 (car numlist)) (cdr numlist)))
      (list-ascii-1)))

(defn MAKE-SYMBOL (initial digit-list)
  (pack (append (append initial digit-list) 0)))

(disable make-symbol)

(defn COUNT-CODELIST1 (numlist)
  ;; NUMLIST is a list of Ascii codes, units digit first if we
  ;; think of them as being codes of digits of a number
  (if (listp numlist)
      (plus (car numlist)
	    (times 10 (count-codelist1 (cdr numlist))))
      0))

(defn SUBSEQP (list1 list2)
  (and (not (lessp (length list2) (length list1)))
       (equal (firstn (length list1) list2) list1)))

(disable subseqp)

(defn COUNT-CODELIST (initial ascii-list)
  (if (subseqp initial ascii-list)
      (count-codelist1 (restn (length initial) ascii-list))
      0))

(disable count-codelist)

(defn MAX-COUNT-CODELIST (initial list)
  (if (listp list)
      (max (count-codelist initial (unpack (car list)))
	   (max-count-codelist initial (cdr list)))
    0))

(prove-lemma INCREMENT-NUM-LIST-COUNT-CODE-LIST1 (rewrite)
  (lessp (count-codelist1 num-list)
	 (count-codelist1 (increment-numlist num-list)))
  ((disable plus-add1-arg1)))

(prove-lemma SUBSEQP-APPEND (rewrite)
  (subseqp (plist x) (append x anything))
  ((enable subseqp)))

(prove-lemma COUNT-CODELIST-MAKE-SYMBOL (rewrite)
  (implies (equal x (make-symbol initial num-list))
	   (equal (count-codelist (plist initial) (unpack x))
		  (count-codelist1 num-list)))
  ((enable count-codelist make-symbol)))

(prove-lemma MEMBER-MAKE-SYMBOL-MAX-COUNT-CODE-LIST (rewrite)
  (implies (member (make-symbol initial num-list) atom-list)
	   (not (lessp (max-count-codelist (plist initial) atom-list)
		       (count-codelist1 num-list))))
  ((expand (max-count-codelist (plist initial) atom-list))))

;; Returns a pair, the new symbol and the next number to use
(defn GENSYM (initial num-list atom-list)
  (if (member (make-symbol initial num-list) atom-list)
      (gensym initial (increment-numlist num-list) atom-list)
      (cons (make-symbol initial num-list)
	    (increment-numlist num-list)))
  ((lessp (difference (add1 (max-count-codelist (plist initial) atom-list))
		      (count-codelist1 num-list)))))


(prove-lemma GENSYM-IS-NEW (rewrite)
  (not (member (car (gensym initial num-list atom-list)) atom-list)))

;; MAKE-TEMP-NAME-ALIST takes a temps-alist triple a la S-TEMPS and
;; returns an alist with entries of the form:
;; (<temp expression> . <variable>) where <variable> is guaranteed to
;; occur only once in the resulting alist and is guaranteed not to occur
;; in FORMALS.
(defn LR-MAKE-TEMP-NAME-ALIST-1 (initial num-list temp-list formals)
  (if (listp temp-list)
      (let ((gensym (gensym initial num-list formals)))
	(cons (cons (car temp-list) (car gensym))
	      (lr-make-temp-name-alist-1 initial
					 (cdr gensym)
					 (cdr temp-list)
					 formals)))
      nil))

(defn LR-MAKE-TEMP-NAME-ALIST (temp-list formals)
  (lr-make-temp-name-alist-1 (unpack 't*) (list-ascii-0) temp-list formals))

(defn LR-NEW-CONS (car cdr)
  (lr-new-node (tag 'nat (lr-cons-tag)) (tag 'nat 1) car cdr))
  
;; Deposit LIST of objects at ADDR, ADDR+1, ADDR+2, ... in DATA-SEG.
(defn DEPOSIT-A-LIST (list addr data-seg)
  (if (listp list)
      (deposit (car list)
	       addr
	       (deposit-a-list (cdr list)
			       (add1-addr addr)
			       data-seg))
      data-seg))

(defn LR-INIT-HEAP-CONTENTS (addr size)
  (if (zerop size)
      (list (tag 'nat (lr-init-tag)))
      (append (lr-new-node (tag 'nat (lr-init-tag))
			   (add-addr addr (lr-node-size))
			   (tag 'nat 0)
			   (tag 'nat 0))
	      (lr-init-heap-contents (add-addr addr (lr-node-size))
				     (sub1 size)))))

(defn LR-ADD-TO-DATA-SEG (data-seg new-node)
  (if (not (lessp (sub1 (length (value (lr-heap-name) data-seg)))
		  (plus (offset (fetch (lr-fp-addr) data-seg))
			(length new-node))))
      (deposit (fetch (add-addr (fetch (lr-fp-addr) data-seg)
				(lr-ref-count-offset))
		      data-seg)
	       (lr-fp-addr)
	       (deposit-a-list new-node
			       (fetch (lr-fp-addr) data-seg)
			       data-seg))
      data-seg))

(defn LR-INIT-DATA-SEG (heap-size)
  (deposit-a-list (list (tag 'nat (lr-false-tag))
			(tag 'nat 1)
			(lr-undef-addr)
			(lr-undef-addr))
		  (lr-f-addr)
		  (deposit-a-list (list (tag 'nat (lr-undefined-tag))
					(tag 'nat 1)
					(lr-undef-addr)
					(lr-undef-addr))
				  (lr-undef-addr)
				  (list (list (area-name (lr-fp-addr))
					      (add-addr (lr-f-addr)
							(lr-node-size)))
					(list (area-name (lr-answer-addr))
					      (tag 'nat 0))
					(cons (lr-heap-name)
					      (lr-init-heap-contents
					       (tag 'addr
						    (cons (lr-heap-name) 0))
					       heap-size))))))

(defn COUNT-LIST (flag object)
  (cond ((equal flag 'list)
	 (if (listp object)
	     (plus (count-list t (car object))
		   (count-list 'list (cdr object)))
	     1))
	((listp object)
	 (add1 (add1 (plus (count-list t (car object))
			   (count-list t (cdr object))))))
	((numberp object)
	 (add1 (count object)))
	(t 1)))

(prove-lemma NOT-EQUAL-0-COUNT-LIST (rewrite)
  (not (equal (count-list flag object) 0)))

(prove-lemma LESSP-COUNT-LIST-CDR-COUNT-LIST-WHOLE (rewrite)
  (implies (listp object)
	   (lessp (count-list 'list (cdr object))
		  (count-list 'list object))))

(prove-lemma LESSP-COUNT-NOT-LIST-CAR-COUNT-LIST-WHOLE (rewrite)
  (implies (listp object)
	   (lessp (count-list t (car object))
		  (count-list 'list object))))

;; LR-COMPILE-QUOTE returns a pair, the new HEAP and the new TABLE.
(defn LR-COMPILE-QUOTE (flag object heap table)
  (cond ((equal flag 'list)
	 (if (listp object)
	     (let ((car-pair (lr-compile-quote t (car object) heap table)))
	       (lr-compile-quote 'list
				 (cdr object)
				 (car car-pair)
				 (cdr car-pair)))
	     (cons heap table)))
	((definedp object table)
	 (cons heap table))
	((listp object)
	 (let ((pair (lr-compile-quote 'list
				       (list (car object) (cdr object))
				       heap
				       table)))
	   (cons (lr-add-to-data-seg (car pair)
				     (lr-new-cons (cdr (assoc
							(car object)
							(cdr pair)))
						  (cdr (assoc
							(cdr object)
							(cdr pair)))))
		 (cons (cons object (fetch (lr-fp-addr) (car pair)))
		       (cdr pair)))))
	((numberp object)
	 (cons (lr-add-to-data-seg heap
				   (lr-new-node (tag 'nat (lr-add1-tag))
						(tag 'nat 1)
						(tag 'nat object)
						(lr-undef-addr)))
	       (cons (cons object
			   (fetch (lr-fp-addr) heap))
		     table)))
	((truep object)
	 (cons (lr-add-to-data-seg heap (lr-new-node (tag 'nat
							  (lr-true-tag))
						     (tag 'nat 1)
						     (lr-undef-addr)
						     (lr-undef-addr)))
	       (cons (cons object (fetch (lr-fp-addr) heap)) table)))
	(t				; Assume it is undefined
	 (cons heap
	       (cons (cons object (lr-undef-addr)) table))))
  ((lessp (count-list flag object))))

;; LR-DATA-SEG-TABLE-BODY returns a pair, the CAR is the extension of
;; DATA-SEG with any constants laid down in it, the CDR is an alist
;; mapping objects in the logic to addresses in the new DATA-SEG
;; where they are represented.  The initial TABLE is such an alist
(defn LR-DATA-SEG-TABLE-BODY (flag expr data-seg table)
  (cond ((equal flag 'list)
	 (if (listp expr)
	     (let ((dst1 (lr-data-seg-table-body t
						 (car expr)
						 data-seg
						 table)))
	       (lr-data-seg-table-body 'list
				       (cdr expr)
				       (car dst1)
				       (cdr dst1)))
	     (cons data-seg table)))
	((listp expr)
	 (cond ((or (equal (car expr) (s-temp-fetch))
		    (equal (car expr) (s-temp-eval))
		    (equal (car expr) (s-temp-test)))
		(lr-data-seg-table-body t (cadr expr) data-seg table))
	       ((equal (car expr) 'quote)
		(lr-compile-quote t (cadr expr) data-seg table))
	       (t (lr-data-seg-table-body 'list
					  (cdr expr)
					  data-seg
					  table))))
	(t;; Should be a litatom
	 (cons data-seg table))))

(defn LR-DATA-SEG-TABLE-LIST (progs data-seg table)
  (if (listp progs)
      (lr-data-seg-table-list (cdr progs)
			      (car (lr-data-seg-table-body
				    t
				    (s-body (car progs))
				    data-seg
				    table))
			      (cdr (lr-data-seg-table-body
				    t
				    (s-body (car progs))
				    data-seg
				    table)))
      (cons data-seg table)))

(defn LR-INIT-DATA-SEG-TABLE (params data-seg table)
  (if (listp params)
      (let ((ds-tab (lr-compile-quote t (cdar params) data-seg table)))
	(lr-init-data-seg-table (cdr params) (car ds-tab) (cdr ds-tab)))
      (cons data-seg table)))

(defn LR-DATA-SEG-TABLE (progs params heap-size)
  (let ((init-ds-table1 (lr-compile-quote 'list
					  (list t 0)
					  (lr-init-data-seg heap-size)
					  (list (cons f (lr-f-addr))))))
    (let ((init-ds-table2 (lr-init-data-seg-table params
						  (car init-ds-table1)
						  (cdr init-ds-table1))))
      (lr-data-seg-table-list progs
			      (car init-ds-table2)
			      (cdr init-ds-table2)))))

(defn PAIR-FORMALS-WITH-ADDRESSES (formals table)
  (if (listp formals)
      (cons (cons (caar formals) (cdr (assoc (cdar formals) table)))
	    (pair-formals-with-addresses (cdr formals) table))
      nil))

(defn LR-MAKE-INITIAL-TEMPS (temp-vars)
  (if (listp temp-vars)
      (cons (cons (car temp-vars) (lr-undef-addr))
	    (lr-make-initial-temps (cdr temp-vars)))
      nil))

(defn LR-INITIAL-CSTK (params temp-alist table pc)
  (list (p-frame (append (pair-formals-with-addresses params table)
			 (lr-make-initial-temps (strip-cdrs temp-alist)))
		 pc)))

(defn LR-COMPILE-BODY (flag body temp-alist const-table)
  (if (equal flag 'list)
      (if (listp body)
	  (cons (lr-compile-body t (car body) temp-alist const-table)
		(lr-compile-body 'list (cdr body) temp-alist const-table))
	  nil)
      (if (listp body)
	  (cond ((or (equal (car body) (s-temp-fetch))
		     (equal (car body) (s-temp-eval))
		     (equal (car body) (s-temp-test)))
		 (list (car body)
		       (lr-compile-body t
					(cadr body)
					temp-alist
					const-table)
		       (value (cadr body) temp-alist)))
		((equal (car body) 'quote)
		 (list 'quote (value (cadr body) const-table)))
		(t (cons (car body)
			 (lr-compile-body 'list
					  (cdr body)
					  temp-alist
					  const-table))))
	  body)))

(defn LR-MAKE-TEMP-VAR-DCLS (temp-alist)
  (if (listp temp-alist)
      (cons (list (cdar temp-alist) (lr-undef-addr))
	    (lr-make-temp-var-dcls (cdr temp-alist)))
      nil))

(defn LR-COMPILE-PROGRAMS (programs const-table)
  (if (listp programs)
      (let ((prog (car programs)))
	(let ((temp-alist (lr-make-temp-name-alist (s-temp-list prog)
						   (s-formals prog))))
	  (cons (lr-make-program (car prog)
				 (s-formals prog)
				 (lr-make-temp-var-dcls temp-alist)
				 (lr-compile-body t
						  (s-body prog)
						  temp-alist
						  const-table))
		(lr-compile-programs (cdr programs) const-table))))
      nil))


(defn LR-P-C-SIZE (flag expr)
  (cond ((equal flag 'list)
	 (if (listp expr)
	     (plus (lr-p-c-size t (car expr))
		   (lr-p-c-size 'list (cdr expr)))
	     0))
	((listp expr)
	 (cond ((equal (car expr) 'if)
		(plus (lr-p-c-size t (cadr expr))
		      (lr-p-c-size t (caddr expr))
		      (lr-p-c-size t (cadddr expr)) 4))
	       ((equal (car expr) (s-temp-fetch)) 1)
	       ((equal (car expr) (s-temp-eval))
		(plus (lr-p-c-size t (cadr expr)) 1))
	       ((equal (car expr) (s-temp-test))
		(plus (lr-p-c-size t (cadr expr)) 7))
	       ((equal (car expr) 'quote) 1)
	       (t (plus (lr-p-c-size 'list (cdr expr)) 1))))
	(t 1)))

(defn LR-P-C-SIZE-LIST (n expr-list)
  (if (zerop n)
      0
      (if (lessp n (length expr-list))
	  (plus (lr-p-c-size t (get n expr-list))
		(lr-p-c-size-list (sub1 n) expr-list))
	  (lr-p-c-size-list (sub1 (length expr-list)) expr-list))))

;; LR-P-PC-1 returns the number of Piton instructions before the start of
;; the expression denoted by POS in the compilation of EXPR.
(defn LR-P-PC-1 (expr pos)
      (cond ((not (listp pos)) 0)
            ((not (listp expr)) 0)
	    ((zerop (car pos)) 0)
            ((equal (car expr) 'if)
	     (cond ((zerop (car pos)) 0)
		   ((equal (car pos) 1)
		    (lr-p-pc-1 (cadr expr) (cdr pos)))
		   ((equal (car pos) 2)
		    (plus 3
			  (lr-p-c-size t (cadr expr))
			  (lr-p-pc-1 (caddr expr) (cdr pos))))
		   (t (plus (lr-p-c-size t (cadr expr))
			    (lr-p-c-size t (caddr expr))
			    (lr-p-pc-1 (cadddr expr) (cdr pos))
			    4))))
            ((equal (car expr) (s-temp-fetch)) 0)
            ((equal (car expr) (s-temp-eval))
             (lr-p-pc-1 (cadr expr) (cdr pos)))
            ((equal (car expr) (s-temp-test))
             (plus (lr-p-pc-1 (cadr expr) (cdr pos)) 4))
            ((equal (car expr) 'quote) 0)
            (t (plus (lr-p-c-size-list (sub1 (car pos)) expr)
                     (lr-p-pc-1 (get (car pos) expr) (cdr pos))))))

(defn LR-P-PC (l)
  (tag 'pc (cons (area-name (p-pc l))
		 (lr-p-pc-1 (program-body (p-current-program l))
			    (offset (p-pc l))))))

(disable lr-p-pc)

(defn S->LR1 (s l table)
  (p-state (tag 'pc (cons (s-pname s) (s-pos s)))
	   (p-ctrl-stk l)
	   (p-temp-stk l)
	   (lr-compile-programs (s-progs s) table)
	   (p-data-segment l)
	   (p-max-ctrl-stk-size l)
	   (p-max-temp-stk-size l)
	   (p-word-size l)
	   (s-err-flag s)))

(disable s->lr1)

;; Returns an P-STATE.
;; FREE-HEAP-SIZE is number of free nodes in resulting P-STATE.
(defn S->LR (s fheap-size max-ctrl max-temp word-size)
  (let ((temp-alist (lr-make-temp-name-alist (strip-cars (s-temps s))
					     (strip-cars (s-params s))))
	(dataseg-table (lr-data-seg-table (s-progs s)
					  (s-params s)
					  fheap-size)))
    (let ((return-pc
	   (tag 'pc
		(cons (s-pname s)
		      (lr-p-pc-1 (lr-compile-body t
						  (s-body (s-prog s))
						  temp-alist
						  (cdr dataseg-table))
				 (s-pos s))))))
      (s->lr1 s
	      (p-state nil
		       (lr-initial-cstk (s-params s)
					temp-alist
					(cdr dataseg-table)
					return-pc)
		       nil
		       nil
		       (car dataseg-table)
		       max-ctrl
		       max-temp
		       word-size
		       nil)
	      (cdr dataseg-table)))))

(disable s->lr)

(defn LR-PARAMS (frame p)
  (firstn (length (formal-vars (p-current-program p))) (bindings frame)))

(disable lr-params)

(defn LR-TEMPS (frame p)
  (restn (length (formal-vars (p-current-program p))) (bindings frame)))

(disable lr-temps)

(defn LR-SET-EXPR (s1 s2 pos)
  (p-state (tag 'pc (cons (area-name (p-pc s2)) pos))
	   (p-ctrl-stk s1)
	   (p-temp-stk s1)
	   (p-prog-segment s2)
	   (p-data-segment s1)
	   (p-max-ctrl-stk-size s1)
	   (p-max-temp-stk-size s1)
	   (p-word-size s1)
	   (p-psw s1)))

(defn LR-SET-ERROR (s flag)
  (p-state (p-pc s)
	   (p-ctrl-stk s)
	   (p-temp-stk s)
	   (p-prog-segment s)
	   (p-data-segment s)
	   (p-max-ctrl-stk-size s)
	   (p-max-temp-stk-size s)
	   (p-word-size s)
	   flag))

(defn LR-SET-POS (s pos)
  (p-state (tag 'pc (cons (area-name (p-pc s)) pos))
	   (p-ctrl-stk s)
	   (p-temp-stk s)
	   (p-prog-segment s)
	   (p-data-segment s)
	   (p-max-ctrl-stk-size s)
	   (p-max-temp-stk-size s)
	   (p-word-size s)
	   (p-psw s)))

(defn LR-SET-TSTK (s temp-stk)
  (p-state (p-pc s)
	   (p-ctrl-stk s)
	   temp-stk
	   (p-prog-segment s)
	   (p-data-segment s)
	   (p-max-ctrl-stk-size s)
	   (p-max-temp-stk-size s)
	   (p-word-size s)
	   (p-psw s)))

(defn LR-POP-TSTK (s)
  (if (equal (p-psw s) 'run)
      (if (listp (p-temp-stk s))
	  (lr-set-tstk s (pop (p-temp-stk s)))
	  (lr-set-error s 'lr-pop-tstk-empty-stack))
      s))

(defn LR-PUSH-TSTK (s value)
  (if (equal (p-psw s) 'run)
      (if (lessp (length (p-temp-stk s)) (p-max-temp-stk-size s))
	  (lr-set-tstk s (push value (p-temp-stk s)))
	  (lr-set-error s 'lr-push-tstk-full-stack))
      s))

(disable lr-push-tstk)

(defn LR-IF-OK (l)
  (if (not (lessp (p-max-temp-stk-size l)
		  (plus 1 (length (p-temp-stk l)))))
      l
      (lr-set-error l 'if-temp-stk-overflow)))

(disable lr-if-ok)

(defn LR-SET-TEMP (s value var-name)
  (if (equal (p-psw s) 'run)
      (p-state (p-pc s)
	       (set-local-var-value value var-name (p-ctrl-stk s))
	       (p-temp-stk s)
	       (p-prog-segment s)
	       (p-data-segment s)
	       (p-max-ctrl-stk-size s)
	       (p-max-temp-stk-size s)
	       (p-word-size s)
	       (p-psw s))
      s))

(disable lr-set-temp)

(defn LR-EVAL-TEMP-SETP (s)
  (not (equal (local-var-value (caddr (lr-expr s)) (p-ctrl-stk s))
	      (lr-undef-addr))))

(disable lr-eval-temp-setp)

(defn LR-DO-TEMP-FETCH (s)
  (if (lr-eval-temp-setp s)
      (lr-push-tstk s
		    (local-var-value (caddr (lr-expr s))
				     (p-ctrl-stk s)))
      (lr-set-error s 'temp-fetch-not-set)))

(disable lr-do-temp-fetch)

(defn LR-POP-CSTK (s)
  (if (equal (p-psw s) 'run)
      (p-state (p-pc s)
	       (pop (p-ctrl-stk s))
	       (p-temp-stk s)
	       (p-prog-segment s)
	       (p-data-segment s)
	       (p-max-ctrl-stk-size s)
	       (p-max-temp-stk-size s)
	       (p-word-size s)
	       (p-psw s))
      s))

(disable lr-pop-cstk)

(defn LR-TYPE-CONTENTS-P (object tag contents)
  (and (equal (type object) tag)
       (equal (untag object) contents)))

;; The following functions are used for the Piton code and to compute the LR
;; value for certain classes of functions (e.g. all shell accessors).

;; NOTE: The 'clock' functions get a Piton state.  This is the state just
;; BEFORE the execution of the appropriate CALL instruction.  Therefore
;; to look at the parameters, it is necessary to look at the temp stack.
;; The clock function return the number of Piton instructions necessary to
;; run the CALL and the code for the SUBR.

;; Recognizers
(defn P-RECOGNIZER-CODE (name tag)
  (list name '() '()
	'(FETCH)
	(list 'PUSH-CONSTANT (tag 'nat tag))
	'(EQ)
	'(TEST-BOOL-AND-JUMP F FALSE)
	(list 'PUSH-CONSTANT (lr-t-addr))
	'(RET)
	(list 'DL 'FALSE '() (LIST 'PUSH-CONSTANT (lr-f-addr)))
	'(RET)))

(defn P-RECOGNIZER-CLOCK (p-state tag) 7)

;; Accessor
(defn P-ACCESSOR-CODE (name tag default offset)
  (list name '(X) '()
	'(PUSH-LOCAL X)
	'(FETCH)
	(list 'PUSH-CONSTANT (tag 'nat TAG))
	'(EQ)
	'(TEST-BOOL-AND-JUMP T ARG1)
	(list 'PUSH-CONSTANT default)
	'(RET)
	'(DL ARG1 () (PUSH-LOCAL X))
	(list 'PUSH-CONSTANT (tag 'nat offset))
	'(ADD-ADDR)
	'(FETCH)
	'(RET)))

(defn P-ACCESSOR-CLOCK (p tag)
  (if (equal (fetch (top (p-temp-stk p)) (p-data-segment p))
	     (tag 'nat tag))
      11
      8))

;; Now comes the actual code and values

(defn P-CAR-CODE ()
  (p-accessor-code 'car (lr-cons-tag) (lr-0-addr) (lr-car-offset)))

(defn P-CAR-CLOCK (p)
  (p-accessor-clock p (lr-cons-tag)))

(disable p-car-clock)

(defn P-CDR-CODE ()
  (p-accessor-code 'cdr (lr-cons-tag) (lr-0-addr) (lr-cdr-offset)))

(defn P-CDR-CLOCK (p)
  (p-accessor-clock p (lr-cons-tag)))

(disable p-cdr-clock)

(defn P-CONS-CODE ()
  ;; Takes two implicit args
  ;; Note that we assume that the CDR is on top of the stack
  ;; and the CAR is just below it.  This is what would normally be
  ;; the case if you evaluate left to right.
  (list 'cons '()
	'((TEMP (NAT 0)))
	'(PUSH-GLOBAL FREE-PTR)		; Put CDR in node + CDR-OFFSET
	(list 'PUSH-CONSTANT (tag 'nat (lr-cdr-offset)))
	'(ADD-ADDR)
	'(DEPOSIT)
	'(PUSH-GLOBAL FREE-PTR)		; Put CAR in node + CAR-OFFSET
	(list 'PUSH-CONSTANT (tag 'nat (lr-car-offset)))
	'(ADD-ADDR)
	'(DEPOSIT)
	'(PUSH-GLOBAL FREE-PTR)		; This is the result
	'(PUSH-GLOBAL FREE-PTR)		; Put FREE-PTR.NEXT on stack
	(list 'PUSH-CONSTANT (tag 'nat (lr-ref-count-offset)))
	'(ADD-ADDR)
	'(SET-LOCAL TEMP)
	'(FETCH)
	'(PUSH-CONSTANT (NAT 1))	; Set ref count to 1
	'(PUSH-LOCAL TEMP)
	'(DEPOSIT)
	(list 'PUSH-CONSTANT (tag 'nat (lr-cons-tag))) ; Put tag in node
	'(PUSH-GLOBAL FREE-PTR)
	'(DEPOSIT)
	'(POP-GLOBAL FREE-PTR)		; FREE-PTR <- FREE-PTR.NEXT
	'(RET)))

(defn P-CONS-CLOCK (p) 23)

(disable p-cons-clock)

(defn P-FALSE-CODE ()
  (list 'false '() '()
	(list 'push-constant (lr-f-addr))
	'(ret)))

(defn P-FALSE-CLOCK (p) 3)

(disable p-false-clock)

;; FALSEP TAKES ONE IMPLICIT ARG ON STACK.
(defn P-FALSEP-CODE ()
  (list 'falsep '() '()
	(list 'PUSH-CONSTANT (lr-f-addr))
	'(EQ)
	'(TEST-BOOL-AND-JUMP T TRUE)
	(list 'PUSH-CONSTANT (lr-f-addr))
	'(RET)
	(list 'DL 'TRUE '() (list 'PUSH-CONSTANT (lr-t-addr)))
	'(RET)))

(defn P-FALSEP-CLOCK (p) 6)

(disable p-falsep-clock)

;; Takes an implicit arg
(defn P-LISTP-CODE ()
  (p-recognizer-code 'listp (lr-cons-tag)))

(defn P-LISTP-CLOCK (p)
  (p-recognizer-clock p (lr-cons-tag)))

(disable p-listp-clock)

(defn P-NLISTP-CODE ()
  (list 'nlistp '() '()
	'(FETCH)
	(list 'PUSH-CONSTANT (tag 'nat (lr-cons-tag)))
	'(EQ)
	'(TEST-BOOL-AND-JUMP F TRUE)
	(list 'PUSH-CONSTANT (lr-f-addr))
	'(RET)
	(list 'DL 'TRUE '() (list 'PUSH-CONSTANT (lr-t-addr)))
	'(RET)))

(defn P-NLISTP-CLOCK (p) 7)

(disable p-nlistp-clock)

(defn P-TRUE-CODE ()
  (list 'true '() '()
	(list 'PUSH-CONSTANT (lr-t-addr))
	'(RET)))

(defn P-TRUE-CLOCK (p) 3)

(disable p-true-clock)

;; The old code for TRUEP is shown below.  I used to ensure that there was
;; only one occurence of TRUE in the data-segment [namely at address
;; (lr-t-addr)], however only TRUEP took advantage of this.  LR-PROPER-HEAPP
;; has been changed to not require only one occurrence, although only one
;; should appear.  However this means we actually have to test the tag, a
;; small performance penalty for some simplicity and freedom in the spec.
(defn P-TRUEP-CODE ()
  (p-recognizer-code 'truep (lr-true-tag)))

;(defn P-TRUEP-CODE ()
;  (list 'truep '() '()
;	(list 'PUSH-CONSTANT (lr-t-addr))
;	'(EQ)
;	'(TEST-BOOL-AND-JUMP T TRUE)
;	(list 'PUSH-CONSTANT (lr-f-addr))
;	'(RET)
;	(list 'DL 'TRUE '() (list 'PUSH-CONSTANT (lr-t-addr)))
;	'(RET)))

(defn P-TRUEP-CLOCK (p)
  (p-recognizer-clock p (lr-false-tag)))

;(defn P-TRUEP-CLOCK (p) 6)

(disable p-truep-clock)

(defn P-RUNTIME-SUPPORT-PROGRAMS ()
  (list (p-car-code)
	(p-cdr-code)
	(p-cons-code)
	(p-false-code)
	(p-falsep-code)
	(p-listp-code)
	(p-nlistp-code)
	(p-true-code)
	(p-truep-code)))

(disable p-runtime-support-programs)

(defn LR-CONVERT-DIGIT-TO-ASCII (digit)
  (plus (ascii-0) digit))

(defn LR-CONVERT-NUM-TO-ASCII (number list)
  (if (lessp number 10)
      (cons (lr-convert-digit-to-ascii number) list)
      (lr-convert-num-to-ascii (quotient number 10)
			       (cons (lr-convert-digit-to-ascii
				      (remainder number 10))
				     list)))
  ((lessp (fix number))))

(defn LR-MAKE-LABEL (n)
  (pack (cons (car (unpack 'L))
	      (cons (ascii-dash)
		    (append (lr-convert-num-to-ascii n nil) 0)))))

(disable lr-make-label)

(defn LABEL-INSTRS (instrs n)
  (if (listp instrs)
      (cons (dl (lr-make-label n) () (car instrs))
	    (label-instrs (cdr instrs) (add1 n)))
      nil))

(defn COMP-TEMP-TEST (expr instrs n)
  ;; Use value if computed,  otherwise compute it.  If we have (CAR EXPR)
  ;; not equal (S-TEMP-TEST) then store the result again
  (append (list (list 'PUSH-LOCAL (caddr expr))
		(list 'PUSH-CONSTANT (lr-undef-addr))
		'(EQ)
		(list 'TEST-BOOL-AND-JUMP 'F
		      (lr-make-label (plus n 6
					   (length instrs)))))
	  (append instrs
		  (list (list 'SET-LOCAL (caddr expr))
			(list 'JUMP
			      (lr-make-label
			       (plus n 7 (length instrs))))
			(list 'PUSH-LOCAL (caddr expr))))))

(defn COMP-IF (test-instrs then-instrs else-instrs n)
  (append test-instrs
	  (append (list (list 'PUSH-CONSTANT (lr-f-addr))
			'(EQ)
			(list 'TEST-BOOL-AND-JUMP 'T
			      (lr-make-label (plus n 4
						   (length test-instrs)
						   (length then-instrs)))))
		  (append then-instrs
			  (cons (list 'JUMP
				      (lr-make-label
				       (plus n 4
					     (length test-instrs)
					     (length then-instrs)
					     (length else-instrs))))
				else-instrs)))))

;; COMP-BODY-1 returns a list of Piton instructions to compile EXPR.
;; N is the number of Piton instructions previously generated, it is used
;; to generate unique labels.
(defn COMP-BODY-1 (flag expr n)
  (cond ((equal flag 'list)
	 (if (listp expr)
	     (append (comp-body-1 t (car expr) n)
		     (comp-body-1 'list
				  (cdr expr)
				  (plus n (lr-p-c-size t (car expr)))))
	     nil))
	((listp expr)
	 (cond ((equal (car expr) 'if)
		(comp-if (comp-body-1 t (cadr expr) n)
			 (comp-body-1 t
				      (caddr expr)
				      (plus n 3
					    (lr-p-c-size t (cadr expr))))
			 (comp-body-1 t
				      (cadddr expr)
				      (plus n 4
					    (lr-p-c-size t (cadr expr))
					    (lr-p-c-size t (caddr expr))))
			 n))
	       ((equal (car expr) (s-temp-fetch))
		;; Unconditionally use already computed value.
		(list (list 'PUSH-LOCAL (caddr expr))))
	       ((equal (car expr) (s-temp-eval))
		;; Unconditionally compute value.
		(append (comp-body-1 t (cadr expr) n)
			(list (list 'SET-LOCAL (caddr expr)))))
	       ((equal (car expr) (s-temp-test))
		(comp-temp-test expr
				(comp-body-1 t (cadr expr) (plus n 4))
				n))
	       ((equal (car expr) 'quote)
		(list (list 'PUSH-CONSTANT (cadr expr))))
	       (t (append (comp-body-1 'list (cdr expr) n)
			  (if (definedp (car expr)
					(p-runtime-support-programs))
			      (list (list 'CALL (car expr)))
			      (list (list 'CALL
					  (user-fname (car expr)))))))))
	(t ;; Should be a litatom
	 (list (list 'PUSH-LOCAL expr)))))

(disable comp-body-1)

(defn COMP-BODY (body)
  (label-instrs (append (comp-body-1 t body 0) '((RET))) 0))

(disable comp-body)

(defn COMP-PROGRAMS-1 (programs)
  (if (listp programs)
      (cons (lr-make-program (name (car programs))
			     (formal-vars (car programs))
			     (temp-var-dcls (car programs))
			     (comp-body (program-body (car programs))))
	    (comp-programs-1 (cdr programs)))
      nil))

(defn COMP-PROGRAMS (programs)
  (cons (lr-make-program (name (car programs))
			 (formal-vars (car programs))
			 (temp-var-dcls (car programs))
			 (label-instrs
			  (append (comp-body-1 t
					       (program-body (car programs))
					       0)
				  (list (list 'SET-GLOBAL
					      (area-name (lr-answer-addr)))
					'(RET)))
			  0))
	(append (comp-programs-1 (cdr programs))
		(p-runtime-support-programs))))

(disable comp-programs)

(defn LR-PROPER-EXPRP (flag expr pnames formals temps table)
  (cond ((equal flag 'list)
	 (if (listp expr)
	     (and (lr-proper-exprp t (car expr) pnames formals temps table)
		  (lr-proper-exprp 'list
				   (cdr expr)
				   pnames
				   formals
				   temps
				   table))
	     (equal expr nil)))
	((litatom expr) (member expr formals))
	((nlistp expr) f)
	((not (plistp expr)) f)
	((equal (car expr) (s-temp-fetch))
	 (and (member (caddr expr) temps) (equal (length expr) 3)))
	((or (equal (car expr) (s-temp-eval))
	     (equal (car expr) (s-temp-test)))
	 (and (member (caddr expr) temps)
	      (equal (length expr) 3)
	      (lr-proper-exprp t (cadr expr) pnames formals temps table)))
	((equal (car expr) 'quote)
	 ;; We need to know that the quoted thing is an address into
	 ;; the data segment, i.e. has TYPE = 'ADDR.  This is because
	 ;; a quote becomes a PUSH-CONSTANT, which can push a PC which would
	 ;; not work.
	 (and (equal (type (cadr expr)) 'addr)
	      (member (cadr expr) (strip-cdrs table))
	      (equal (length (cdr expr)) (arity (car expr)))))
	((subrp (car expr))
	 (and (equal (length (cdr expr)) (arity (car expr)))
	      ;; ***** This will have to change when user definedp subrs are
	      ;; implemented. *****
	      (or (equal (car expr) 'if)
		  (definedp (car expr) (p-runtime-support-programs)))
	      (not (member (car expr) pnames))
	      (lr-proper-exprp 'list (cdr expr)
			       pnames formals temps table)))
	((body (car expr))
	 (and (equal (length (cdr expr)) (arity (car expr)))
	      (member (car expr) pnames)
	      (lr-proper-exprp 'list (cdr expr)
			       pnames formals temps table)))
	(t f)))

(defn ALL-UNDEF-ADDRS (list)
  (if (listp list)
      (and (equal (car list) (lr-undef-addr))
	   (all-undef-addrs (cdr list)))
      t))

(defn LR-PROGRAMS-PROPERP-1 (programs program-names table)
  (if (listp programs)
      (and ;(not (subrp (name (car programs))))
	   ;(litatom (name (car programs)))
	   (all-litatoms (formal-vars (car programs)))
	   (all-litatoms (strip-cars (temp-var-dcls (car programs))))
	   (all-undef-addrs (strip-cadrs (temp-var-dcls (car programs))))
	   (lr-proper-exprp t
			    (program-body (car programs))
			    program-names
			    (formal-vars (car programs))
			    (strip-cars (temp-var-dcls (car programs)))
			    table)
	   (lr-programs-properp-1 (cdr programs) program-names table))
      t))

(disable lr-programs-properp-1)

(defn LR-PROGRAMS-PROPERP (l table)
  (and (definedp (area-name (p-pc l)) (p-prog-segment l))
       (equal (caar (p-prog-segment l)) 'main)
       (all-user-fnamesp (cdr (strip-cars (p-prog-segment l))))
       (lr-programs-properp-1 (p-prog-segment l)
			      (strip-logic-fnames (cdr (p-prog-segment l)))
			      table)))

(disable lr-programs-properp)

(prove-lemma LR-P-C-SIZE-FLAG-NOT-LIST-NOT-0 (rewrite)
  (implies (not (equal flag 'list))
	   (not (equal (lr-p-c-size flag expr) 0))))

(prove-lemma DIFFERENCE-DECREASES (rewrite)
  (implies (and (not (lessp x y))
		(not (zerop y)))
	   (equal (lessp (difference x y) x) t)))

(defn LR->P (p)
  (p-state (lr-p-pc p)
	   (p-ctrl-stk p)
	   (p-temp-stk p)
	   (comp-programs (p-prog-segment p))
	   (p-data-segment p)
	   (p-max-ctrl-stk-size p)
	   (p-max-temp-stk-size p)
	   (p-word-size p)
	   (p-psw p)))

(disable lr->p)

(defn P-SET-PC (p pc)
  (p-state pc
	   (p-ctrl-stk p)
	   (p-temp-stk p)
	   (p-prog-segment p)
	   (p-data-segment p)
	   (p-max-ctrl-stk-size p)
	   (p-max-temp-stk-size p)
	   (p-word-size p)
	   (p-psw p)))

;; It should be the case that (P-CURRENT-INSTRUCTION p) = (CALL subr)
;; therefore we need to run P one more step than the clock functions
;; below to do the CALL.
(defn P-RUN-SUBR (subr p)
  (case subr
    (car		(p p (p-car-clock p)))
    (cdr		(p p (p-cdr-clock p)))
    (cons		(p p (p-cons-clock p)))
    (false		(p p (p-false-clock p)))
    (falsep		(p p (p-falsep-clock p)))
    (listp		(p p (p-listp-clock p)))
    (nlistp		(p p (p-nlistp-clock p)))
    (true		(p p (p-true-clock p)))
    (truep		(p p (p-truep-clock p)))
    (otherwise		(p-halt p 'bad-subr))))

(disable p-run-subr)

(defn LR-RETURN-PC (l)
  (add-addr (lr-p-pc l) (lr-p-c-size 'list (cdr (lr-expr l)))))

(disable lr-return-pc)

(defn LR-APPLY-SUBR (l new-l)
  (let ((res (p-run-subr (car (lr-expr l))
			 (p-set-pc (lr->p new-l) (lr-return-pc l)))))
    (p-state (p-pc new-l)
	     (p-ctrl-stk res)
	     (p-temp-stk res)
	     (p-prog-segment new-l)
	     (p-data-segment res)
	     (p-max-ctrl-stk-size res)
	     (p-max-temp-stk-size res)
	     (p-word-size res)
	     (p-psw res))))

(disable lr-apply-subr)

(defn LR-FUNCALL (l new-l)
  (let ((prog (definition (user-fname (car (lr-expr l)))
			  (p-prog-segment l)))
	(newest-l (p-set-pc (lr->p new-l) (lr-return-pc l))))
    (if (p-call-okp (list 'call (user-fname (car (lr-expr l)))) newest-l)
	(p-state (tag 'pc (cons (user-fname (car (lr-expr l))) nil))
		 (push (make-p-call-frame (formal-vars prog)
					  (p-temp-stk new-l)
					  (temp-var-dcls prog)
					  (add1-addr (p-pc newest-l)))
		       (p-ctrl-stk new-l))
		 (popn (length (formal-vars prog)) (p-temp-stk new-l))
		 (p-prog-segment new-l)
		 (p-data-segment new-l)
		 (p-max-ctrl-stk-size new-l)
		 (p-max-temp-stk-size new-l)
		 (p-word-size new-l)
		 'run)
	(p-halt new-l (x-y-error-msg 'p 'call)))))

(disable lr-funcall)

;; The following lemmas are needed to admit LR-EVAL
(prove-lemma P-ACCESSORS-LR-SET-EXPR (rewrite)
  (and (equal (p-pc (lr-set-expr s1 s2 pos))
	      (tag 'pc (cons (area-name (p-pc s2)) pos)))
       (equal (p-ctrl-stk (lr-set-expr s1 s2 pos)) (p-ctrl-stk s1))
       (equal (p-temp-stk (lr-set-expr s1 s2 pos)) (p-temp-stk s1))
       (equal (p-prog-segment (lr-set-expr s1 s2 pos)) (p-prog-segment s2))
       (equal (p-data-segment (lr-set-expr s1 s2 pos)) (p-data-segment s1))
       (equal (p-max-ctrl-stk-size (lr-set-expr s1 s2 pos))
	      (p-max-ctrl-stk-size s1))
       (equal (p-max-temp-stk-size (lr-set-expr s1 s2 pos))
	      (p-max-temp-stk-size s1))
       (equal (p-word-size (lr-set-expr s1 s2 pos)) (p-word-size s1))
       (equal (p-psw (lr-set-expr s1 s2 pos)) (p-psw s1))))

(disable lr-set-expr)

(prove-lemma P-ACCESSORS-LR-SET-TSTK (rewrite)
  (and (equal (p-pc (lr-set-tstk s ts)) (p-pc s))
       (equal (p-ctrl-stk (lr-set-tstk s ts)) (p-ctrl-stk s))
       (equal (p-temp-stk (lr-set-tstk s ts)) ts)
       (equal (p-prog-segment (lr-set-tstk s ts)) (p-prog-segment s))
       (equal (p-data-segment (lr-set-tstk s ts)) (p-data-segment s))
       (equal (p-max-ctrl-stk-size (lr-set-tstk s ts))
	      (p-max-ctrl-stk-size s))
       (equal (p-max-temp-stk-size (lr-set-tstk s ts))
	      (p-max-temp-stk-size s))
       (equal (p-word-size (lr-set-tstk s ts)) (p-word-size s))
       (equal (p-psw (lr-set-tstk s ts)) (p-psw s))))

(disable lr-set-tstk)

(prove-lemma P-ACCESSORS-LR-SET-ERROR (rewrite)
  (and (equal (p-pc (lr-set-error s flag)) (p-pc s))
       (equal (p-ctrl-stk (lr-set-error s flag)) (p-ctrl-stk s))
       (equal (p-temp-stk (lr-set-error s flag)) (p-temp-stk s))
       (equal (p-prog-segment (lr-set-error s flag)) (p-prog-segment s))
       (equal (p-data-segment (lr-set-error s flag)) (p-data-segment s))
       (equal (p-max-ctrl-stk-size (lr-set-error s flag))
	      (p-max-ctrl-stk-size s))
       (equal (p-max-temp-stk-size (lr-set-error s flag))
	      (p-max-temp-stk-size s))
       (equal (p-word-size (lr-set-error s flag)) (p-word-size s))
       (equal (p-psw	(lr-set-error s flag)) flag)))

(disable lr-set-error)

(prove-lemma P-ACCESSORS-LR-SET-POS (rewrite)
  (and (equal (p-pc (lr-set-pos s pos)) (tag 'pc
					     (cons (area-name (p-pc s))
						   pos)))
       (equal (p-ctrl-stk (lr-set-pos s pos)) (p-ctrl-stk s))
       (equal (p-temp-stk (lr-set-pos s pos)) (p-temp-stk s))
       (equal (p-prog-segment (lr-set-pos s pos)) (p-prog-segment s))
       (equal (p-data-segment (lr-set-pos s pos)) (p-data-segment s))
       (equal (p-max-ctrl-stk-size (lr-set-pos s pos))
	      (p-max-ctrl-stk-size s))
       (equal (p-max-temp-stk-size (lr-set-pos s pos))
	      (p-max-temp-stk-size s))
       (equal (p-word-size (lr-set-pos s pos)) (p-word-size s))
       (equal (p-psw (lr-set-pos s pos)) (p-psw s))))

(disable lr-set-pos)

(prove-lemma P-ACCESSORS-LR-POP-TSTK (rewrite)
  (and (equal (p-pc (lr-pop-tstk s)) (p-pc s))
       (equal (p-ctrl-stk (lr-pop-tstk s)) (p-ctrl-stk s))
       (equal (p-prog-segment (lr-pop-tstk s)) (p-prog-segment s))
       (equal (p-data-segment (lr-pop-tstk s)) (p-data-segment s))
       (equal (p-max-ctrl-stk-size (lr-pop-tstk s))
	      (p-max-ctrl-stk-size s))
       (equal (p-max-temp-stk-size (lr-pop-tstk s))
	      (p-max-temp-stk-size s))
       (equal (p-word-size (lr-pop-tstk s)) (p-word-size s))))

(prove-lemma P-TEMP-STK-LR-POP-TSTK (rewrite)
  (equal (p-temp-stk (lr-pop-tstk s))
	 (if (and (listp (p-temp-stk s))
		  (equal (p-psw s) 'run))
	     (pop (p-temp-stk s))
	     (p-temp-stk s))))

(disable lr-pop-tstk)

(prove-lemma AREA-NAME-TAG (rewrite)
  (equal (area-name (tag tag adp)) (adp-name adp))
  ((enable area-name tag untag)))

(prove-lemma OFFSET-TAG (rewrite)
  (equal (offset (tag tag adp)) (adp-offset adp))
  ((enable offset tag untag)))

(prove-lemma P-CURRENT-PROGRAM-LR-SET-EXPR (rewrite)
  (equal (p-current-program (lr-set-expr s1 s2 pos)) (p-current-program s2))
  ((enable p-current-program)))

(prove-lemma P-CURRENT-PROGRAM-LR-SET-POS (rewrite)
  (equal (p-current-program (lr-set-pos s pos)) (p-current-program s))
  ((enable p-current-program)))

(prove-lemma LR-EXPR-LR-SET-EXPR (rewrite)
  (equal (lr-expr (lr-set-expr s1 s2 (dv (offset (p-pc s2)) n)))
	 (get n (lr-expr s2)))
  ((enable lr-expr p-current-program dv)))

(prove-lemma LR-EXPR-LR-SET-POS-T (rewrite)
  (equal (lr-expr (lr-set-pos s (dv (offset (p-pc s)) n)))
	 (get n (lr-expr s)))
  ((enable lr-expr dv)))

(prove-lemma LR-EXPR-FLAG-LIST-CAR (rewrite)
  (implies (listp (offset (p-pc p)))
	   (equal (car (lr-expr-list p)) (lr-expr p)))
  ((enable lr-expr lr-expr-list
	   car-restn-get)
   (use (cur-expr-append (pos1 (butlast (offset (p-pc p))))
			 (pos2 (last (offset (p-pc p))))
			 (body (program-body (p-current-program p)))))
   (expand (cur-expr (last (offset (p-pc p)))
		     (cur-expr (butlast (offset (p-pc p)))
			       (program-body (p-current-program p))))
	   (cur-expr (cdr (last (offset (p-pc p))))
		     (get (car (last (offset (p-pc p))))
			  (cur-expr (butlast (offset (p-pc p)))
				    (program-body (p-current-program p))))))
   (disable cur-expr
	    cur-expr-append)))

(prove-lemma NUMBER-CONS-LR-EXPR-T-LIST (rewrite)
  (implies (and (listp (lr-expr-list p))
		(listp (offset (p-pc p))))
	   (lessp (number-cons (lr-expr p))
		  (number-cons (lr-expr-list p))))
  ((enable lr-expr lr-expr-list)))

(prove-lemma LR-EXPR-LR-SET-EXPR-NX (rewrite)
  (implies (and (listp (offset (p-pc p)))
		(listp (lr-expr-list p)))
	   (equal (lr-expr-list (lr-set-expr p1 p (nx (offset (p-pc p)))))
		  (cdr (lr-expr-list p))))
  ((enable lr-expr-list
	   restn-cdr)))

(prove-lemma LR-EXPR-LIST-LR-SET-POS-DV-1 (rewrite)
  (implies (listp (lr-expr p))
	   (equal (lr-expr-list (lr-set-pos p (dv (offset (p-pc p)) 1)))
		  (cdr (lr-expr p))))
  ((enable lr-expr lr-expr-list)))

;; If FLAG is 'LIST then state contains a list of expressions,
;; otherwise it is just one.
;; Returns a P-STATE.  The result is left on the temp stack.
;; If the error flag of the resulting state is 'HALT then we terminated
;; normally.  If the flag is 'RUN we have not terminated yet.
;; If the flag is anything else we got an error.
(defn LR-EVAL (flag l c)
  (cond ((not (equal (p-psw l) 'run)) l)
	((equal flag 'list)
	 (if (nlistp (offset (p-pc l)))
	     (lr-set-error l 'bad-list-position)
	     (if (listp (lr-expr-list l))
		 (lr-eval 'list
			  (lr-set-expr (lr-eval t l c)
				       l
				       (nx (offset (p-pc l))))
			  c)
		 l)))
	((zerop c) (lr-set-error l 'out-of-time))
	((litatom (lr-expr l))
	 (lr-push-tstk l (local-var-value (lr-expr l) (p-ctrl-stk l))))
	((nlistp (lr-expr l)) (lr-set-error l 'bad-expression))
	((equal (car (lr-expr l)) 'if)
	 (let ((test (lr-if-ok (lr-eval t
					(lr-set-pos l
						    (dv (offset (p-pc l))
							1))
					c))))
	   (if (equal (p-psw test) 'run)
	       (if (not (equal (top (p-temp-stk test)) (lr-f-addr)))
		   (lr-eval t
			    (lr-set-expr (lr-pop-tstk test)
					 l
					 (dv (offset (p-pc l)) 2))
			    c)
		   (lr-eval t
			    (lr-set-expr (lr-pop-tstk test)
					 l
					 (dv (offset (p-pc l)) 3))
			    c))
	       test)))
	((equal (car (lr-expr l)) (s-temp-eval))
	 (let ((l1 (lr-eval t (lr-set-pos l (dv (offset (p-pc l)) 1)) c)))
	   (lr-set-temp l1 (top (p-temp-stk l1)) (caddr (lr-expr l)))))
	((equal (car (lr-expr l)) (s-temp-test))
	 (let ((l1 (lr-eval t (lr-set-pos l (dv (offset (p-pc l)) 1)) c)))
	   (if (not (lessp (p-max-temp-stk-size l)
			   (plus 2 (length (p-temp-stk l)))))
	       (if (lr-eval-temp-setp l)
		   (lr-do-temp-fetch l)
		   (lr-set-temp l1
				(top (p-temp-stk l1))
				(caddr (lr-expr l))))
	       (lr-set-error l 'lr-temp-setp-temp-stack-overflow))))
	((equal (car (lr-expr l)) (s-temp-fetch)) (lr-do-temp-fetch l))
	((equal (car (lr-expr l)) 'quote)
	 (lr-push-tstk l (cadr (lr-expr l))))
	((not (equal (p-psw (lr-eval 'list
				     (lr-set-pos l (dv (offset (p-pc l)) 1))
				     c))
		     'run))
	 (lr-eval 'list (lr-set-pos l (dv (offset (p-pc l)) 1)) c))
	((subrp (car (lr-expr l)))
	 (lr-apply-subr l
			(lr-eval 'list
				 (lr-set-pos l (dv (offset (p-pc l)) 1))
				 c)))
	((litatom (car (lr-expr l)))
	 (let ((fs (lr-funcall l
			       (lr-eval 'list
					(lr-set-pos l
						    (dv (offset (p-pc l))
							1))
					c))))
	   (lr-set-expr (lr-pop-cstk (lr-eval t fs (sub1 c)))
			l
			(offset (p-pc l)))))
	(t (lr-set-error l 'bad-instruction)))
  ((ord-lessp (cons (add1 c) (if (equal flag 'list)
				 (number-cons (lr-expr-list l))
				 (number-cons (lr-expr l)))))))

;; Proper LR STATES

;; Sometimes we only need to know that LR-PROPER-P-AREASP holds on
;; a data-segment instead of LR-PROPER-P-DATA-SEGMENTP
(defn LR-PROPER-P-AREASP (data-seg)
  (if (nlistp data-seg)
      (equal data-seg nil)
      (let ((area (car data-seg)))
	(and (litatom (car area))
	     (listp (cdr area))
	     (not (definedp (car area) (cdr data-seg)))
	     (lr-proper-p-areasp (cdr data-seg))))))

;; First we prove that LR-EVAL preserves PROPER-P-STATEP.

(prove-lemma P-ACCESSORS-LR-FUNCALL (rewrite)
  (and (equal (p-prog-segment (lr-funcall l new-l)) (p-prog-segment new-l))
       (equal (p-data-segment (lr-funcall l new-l)) (p-data-segment new-l))
       (equal (p-max-ctrl-stk-size (lr-funcall l new-l))
	      (p-max-ctrl-stk-size new-l))
       (equal (p-max-temp-stk-size (lr-funcall l new-l))
	      (p-max-temp-stk-size new-l))
       (equal (p-word-size (lr-funcall l new-l)) (p-word-size new-l)))
  ((enable lr-funcall)
   (disable-theory addition)
   (disable make-p-call-frame p-call-okp lr-p-c-size lr-p-c-size-list)))

(prove-lemma P-ACCESSORS-LR-PUSH-TSTK (rewrite)
  (and (equal (p-pc (lr-push-tstk s v)) (p-pc s))
       (equal (p-ctrl-stk (lr-push-tstk s v)) (p-ctrl-stk s))
       (equal (p-prog-segment (lr-push-tstk s v)) (p-prog-segment s))
       (equal (p-data-segment (lr-push-tstk s v)) (p-data-segment s))
       (equal (p-max-ctrl-stk-size (lr-push-tstk s v))
	      (p-max-ctrl-stk-size s))
       (equal (p-max-temp-stk-size (lr-push-tstk s v))
	      (p-max-temp-stk-size s))
       (equal (p-word-size (lr-push-tstk s v)) (p-word-size s)))
  ((enable lr-push-tstk)))

(prove-lemma P-ACCESSORS-LR-IF-OK (rewrite)
  (and (equal (p-pc (lr-if-ok l)) (p-pc l))
       (equal (p-ctrl-stk (lr-if-ok l)) (p-ctrl-stk l))
       (equal (p-temp-stk (lr-if-ok l)) (p-temp-stk l))
       (equal (p-prog-segment (lr-if-ok l)) (p-prog-segment l))
       (equal (p-data-segment (lr-if-ok l)) (p-data-segment l))
       (equal (p-max-ctrl-stk-size (lr-if-ok l)) (p-max-ctrl-stk-size l))
       (equal (p-max-temp-stk-size (lr-if-ok l)) (p-max-temp-stk-size l))
       (equal (p-word-size (lr-if-ok l)) (p-word-size l)))
  ((enable lr-if-ok)))

(prove-lemma P-ACCESSORS-LR-SET-TEMP (rewrite)
  (and (equal (p-pc (lr-set-temp s v n)) (p-pc s))
       (equal (p-ctrl-stk (lr-set-temp s v n))
	      (if (equal (p-psw s) 'run)
		  (set-local-var-value v n (p-ctrl-stk s))
		  (p-ctrl-stk s)))
       (equal (p-temp-stk (lr-set-temp s v n)) (p-temp-stk s))
       (equal (p-prog-segment (lr-set-temp s v n)) (p-prog-segment s))
       (equal (p-data-segment (lr-set-temp s v n)) (p-data-segment s))
       (equal (p-max-ctrl-stk-size (lr-set-temp s v n))
	      (p-max-ctrl-stk-size s))
       (equal (p-max-temp-stk-size (lr-set-temp s v n))
	      (p-max-temp-stk-size s))
       (equal (p-word-size (lr-set-temp s v n)) (p-word-size s))
       (equal (p-psw (lr-set-temp s v n)) (p-psw s)))
  ((enable lr-set-temp)
   (disable set-local-var-value)))

(prove-lemma P-ACCESSORS-LR-DO-TEMP-FETCH (rewrite)
  (and (equal (p-pc (lr-do-temp-fetch s)) (p-pc s))
       (equal (p-ctrl-stk (lr-do-temp-fetch s)) (p-ctrl-stk s))
       (equal (p-prog-segment (lr-do-temp-fetch s)) (p-prog-segment s))
       (equal (p-data-segment (lr-do-temp-fetch s)) (p-data-segment s))
       (equal (p-max-ctrl-stk-size (lr-do-temp-fetch s))
	      (p-max-ctrl-stk-size s))
       (equal (p-max-temp-stk-size (lr-do-temp-fetch s))
	      (p-max-temp-stk-size s))
       (equal (p-word-size (lr-do-temp-fetch s)) (p-word-size s)))
  ((enable lr-do-temp-fetch)
   (disable local-var-value)))

(prove-lemma P-ACCESSORS-LR-POP-CSTK (rewrite)
  (and (equal (p-pc (lr-pop-cstk s)) (p-pc s))
       (equal (p-ctrl-stk (lr-pop-cstk s)) (if (equal (p-psw s) 'run)
						(pop (p-ctrl-stk s))
						(p-ctrl-stk s)))
       (equal (p-temp-stk (lr-pop-cstk s)) (p-temp-stk s))
       (equal (p-prog-segment (lr-pop-cstk s)) (p-prog-segment s))
       (equal (p-data-segment (lr-pop-cstk s)) (p-data-segment s))
       (equal (p-max-ctrl-stk-size (lr-pop-cstk s)) (p-max-ctrl-stk-size s))
       (equal (p-max-temp-stk-size (lr-pop-cstk s)) (p-max-temp-stk-size s))
       (equal (p-word-size (lr-pop-cstk s)) (p-word-size s))
       (equal (p-psw (lr-pop-cstk s)) (p-psw s)))
  ((enable lr-pop-cstk)))

(prove-lemma LR-EVAL-IF-P-PSW-1 (rewrite)
  (implies (and (not (equal flag 'list))
		(equal (p-psw (lr-eval flag l c)) 'run)
		(equal (car (lr-expr l)) 'if)
		(equal (p-psw l) 'run)
		(not (zerop c))
		(listp (lr-expr l)))
	   (equal (p-psw (lr-eval t
				  (lr-set-pos l (dv (offset (p-pc l)) 1))
				  c))
		  'run))
    ((enable lr-pop-tstk lr-if-ok)
     (expand (lr-eval flag l c))))

(disable lr-eval-if-p-psw-1)

(prove-lemma ADP-OFFSET-UNTAG-ADD-ADDR (rewrite)
  (equal (adp-offset (untag (add-addr addr n))) (plus (offset addr) n))
  ((enable offset untag add-addr tag)))

(prove-lemma ADP-OFFSET-UNTAG-SUB-ADDR (rewrite)
  (equal (adp-offset (untag (sub-addr addr n)))
	 (difference (offset addr) n))
  ((enable offset untag sub-addr tag)))

(prove-lemma ADP-NAME-UNTAG-SUB-ADDR (rewrite)
  (equal (adp-name (untag (sub-addr addr n))) (adp-name (untag addr)))
  ((enable adp-name untag sub-addr tag)))

(prove-lemma ADP-OFFSET-CONS (rewrite)
  (equal (adp-offset (cons area-name offset)) offset))

(prove-lemma P-ACCESSORS-LR->P (rewrite)
  (and (equal (p-pc (lr->p l)) (lr-p-pc l))
       (equal (p-ctrl-stk (lr->p l)) (p-ctrl-stk l))
       (equal (p-temp-stk (lr->p l)) (p-temp-stk l))
       (equal (p-prog-segment (lr->p l)) (comp-programs (p-prog-segment l)))
       (equal (p-data-segment (lr->p l)) (p-data-segment l))
       (equal (p-max-ctrl-stk-size (lr->p l)) (p-max-ctrl-stk-size l))
       (equal (p-max-temp-stk-size (lr->p l)) (p-max-temp-stk-size l))
       (equal (p-word-size (lr->p l)) (p-word-size l))
       (equal (p-psw (lr->p l)) (p-psw l)))
  ((enable lr->p)))

(prove-lemma TYPE-LR-P-PC (rewrite)
  (equal (type (lr-p-pc l)) 'pc)
  ((enable lr-p-pc)
   (disable lr-p-pc-1)))

(prove-lemma CDDR-NIL-LR-P-PC (rewrite)
  (equal (cddr (lr-p-pc l)) nil)
  ((enable lr-p-pc)
   (disable lr-p-pc-1)))

(prove-lemma LISTP-UNTAG-LR-P-PC (rewrite)
  (listp (untag (lr-p-pc l)))
  ((enable lr-p-pc)
   (disable lr-p-pc-1)))

(prove-lemma NUMBERP-CDR-LR-P-PC (rewrite)
  (numberp (cdr (untag (lr-p-pc l))))
  ((enable lr-p-pc)
   (disable lr-p-pc-1)))

(prove-lemma CAR-UNTAG-LR-P-PC (rewrite)
  (equal (car (untag (lr-p-pc p))) (car (untag (p-pc p))))
  ((enable area-name lr-p-pc)
   (disable lr-p-pc-1)))

(prove-lemma AREA-NAME-LR-P-PC (rewrite)
  (equal (area-name (lr-p-pc p)) (area-name (p-pc p)))
  ((enable lr-p-pc)
   (disable lr-p-pc-1)))

(prove-lemma DEFINEDP-COMP-PROGRAMS-1-DEFINEDP-ORIG (rewrite)
  (equal (definedp x (comp-programs-1 programs)) (definedp x programs))
  ((enable name)))

(prove-lemma DEFINEDP-APPEND (rewrite)
  (equal (definedp x (append l1 l2))
	 (or (definedp x l1) (definedp x l2))))

(prove-lemma DEFINEDP-COMP-PROGRAMS-DEFINEDP-ORIG (rewrite)
  (implies (definedp x programs)
	   (definedp x (comp-programs programs)))
  ((enable comp-programs name)
   (disable *1*p-runtime-support-programs)))

(prove-lemma P-ACCESSORS-P-HALT (rewrite)
  (and (equal (p-pc (p-halt p psw)) (p-pc p))
       (equal (p-ctrl-stk (p-halt p psw)) (p-ctrl-stk p))
       (equal (p-temp-stk (p-halt p psw)) (p-temp-stk p))
       (equal (p-prog-segment (p-halt p psw)) (p-prog-segment p))
       (equal (p-data-segment (p-halt p psw)) (p-data-segment p))
       (equal (p-max-ctrl-stk-size (p-halt p psw)) (p-max-ctrl-stk-size p))
       (equal (p-max-temp-stk-size (p-halt p psw)) (p-max-temp-stk-size p))
       (equal (p-word-size (p-halt p psw)) (p-word-size p))
       (equal (p-psw (p-halt p psw)) psw)))

(disable p-halt)

(prove-lemma P-ACCESSORS-P-SET-PC (rewrite)
  (and (equal (p-pc (p-set-pc p pc)) pc)
       (equal (p-ctrl-stk (p-set-pc p pc)) (p-ctrl-stk p))
       (equal (p-temp-stk (p-set-pc p pc)) (p-temp-stk p))
       (equal (p-prog-segment (p-set-pc p pc)) (p-prog-segment p))
       (equal (p-data-segment (p-set-pc p pc)) (p-data-segment p))
       (equal (p-max-ctrl-stk-size (p-set-pc p pc)) (p-max-ctrl-stk-size p))
       (equal (p-max-temp-stk-size (p-set-pc p pc)) (p-max-temp-stk-size p))
       (equal (p-word-size (p-set-pc p pc)) (p-word-size p))
       (equal (p-psw (p-set-pc p pc)) (p-psw p))))

(disable p-set-pc)

(prove-lemma P-PSW-NOT-RUN ()
  (implies (not (equal (p-psw p-state) 'run))
	   (equal (p p-state clock) p-state))
  ((enable p)))

(prove-lemma P-PSW-P-HALT-X-Y-ERROR-MSG (rewrite)
  (equal (p (p-halt p-state (x-y-error-msg x y)) n)
	 (p-halt p-state (x-y-error-msg x y)))
  ((enable p p-halt)
   (disable *1*x-y-error-msg)
   (use (p-psw-not-run (p-state (p-halt p-state (x-y-error-msg x y)))
		       (clock n)))))

(disable p-psw-p-halt-x-y-error-msg)

(prove-lemma P-ACCESSORS-P-RUN-SUBR (rewrite)
  (and (equal (p-prog-segment (p-run-subr subr p)) (p-prog-segment p))
       (equal (p-max-ctrl-stk-size (p-run-subr subr p))
	      (p-max-ctrl-stk-size p))
       (equal (p-max-temp-stk-size (p-run-subr subr p))
	      (p-max-temp-stk-size p))
       (equal (p-word-size (p-run-subr subr p)) (p-word-size p)))
  ((disable p-ins-okp
	    *1*x-y-error-msg)
   (enable p-run-subr
	   p-step1-opener
	   p-psw-p-halt-x-y-error-msg)))

(prove-lemma P-ACCESSORS-LR-APPLY-SUBR (rewrite)
  (and (equal (p-pc (lr-apply-subr l1 l2)) (p-pc l2))
       (equal (p-prog-segment (lr-apply-subr l1 l2)) (p-prog-segment l2))
       (equal (p-max-ctrl-stk-size (lr-apply-subr l1 l2))
	      (p-max-ctrl-stk-size l2))
       (equal (p-max-temp-stk-size (lr-apply-subr l1 l2))
	      (p-max-temp-stk-size l2))
       (equal (p-word-size (lr-apply-subr l1 l2)) (p-word-size l2)))
  ((enable lr-apply-subr p-invariant1)
   (disable p-ins-step lr-p-c-size lr-p-c-size-list
	    *1*x-y-error-msg p-ins-okp)))

(prove-lemma P-PROG-SEGMENT-LR-EVAL (rewrite)
  (equal (p-prog-segment (lr-eval flag l c)) (p-prog-segment l))
  ((induct (lr-eval flag l c))
   (expand (lr-eval flag l c) (lr-eval 'list l c) (lr-eval flag l 0))
   (disable lr-eval)))

(prove-lemma P-MAX-CTRL-STK-SIZE-LR-EVAL (rewrite)
  (equal (p-max-ctrl-stk-size (lr-eval flag l c)) (p-max-ctrl-stk-size l))
  ((induct (lr-eval flag l c))
   (expand (lr-eval flag l c) (lr-eval 'list l c) (lr-eval flag l 0))
   (disable lr-eval)))

(prove-lemma P-MAX-TEMP-STK-SIZE-LR-EVAL (rewrite)
  (equal (p-max-temp-stk-size (lr-eval flag l c)) (p-max-temp-stk-size l))
  ((induct (lr-eval flag l c))
   (expand (lr-eval flag l c) (lr-eval 'list l c) (lr-eval flag l 0))
   (disable lr-eval)))

(prove-lemma P-WORD-SIZE-LR-EVAL (rewrite)
  (equal (p-word-size (lr-eval flag l c)) (p-word-size l))
  ((induct (lr-eval flag l c))
   (expand (lr-eval flag l c) (lr-eval 'list l c) (lr-eval flag l 0))
   (disable lr-eval)))

(prove-lemma AREA-NAME-P-PC-LR-EVAL (rewrite)
  (equal (area-name (p-pc (lr-eval flag l c))) (area-name (p-pc l)))
  ((induct (lr-eval flag l c))
   (expand (lr-eval flag l c) (lr-eval 'list l c) (lr-eval flag l 0))
   (disable lr-eval)))

(prove-lemma LR-PROGRAMS-PROPERP-LR-EVAL (rewrite)
  (equal (lr-programs-properp (lr-eval flag l c) table)
	 (lr-programs-properp l table))
  ((enable lr-programs-properp)))

(prove-lemma DEFINEDP-DEPOSIT (rewrite)
  (equal (definedp tag (deposit anything addr data-seg))
	 (definedp tag data-seg))
  ((enable deposit)))

(prove-lemma DEPOSIT-A-LIST-CONS-OPENER (rewrite)
  (equal (deposit-a-list (cons x list) addr data-seg)
	 (deposit x addr (deposit-a-list list (add1-addr addr) data-seg))))

(prove-lemma DEPOSIT-A-LIST-NIL (rewrite)
  (equal (deposit-a-list nil addr data-seg) data-seg))

(disable deposit-a-list)

(prove-lemma ASSOC-PUT-ASSOC-3 (rewrite)
  (equal (assoc name1 (put-assoc val name2 alist))
	 (if (equal name1 name2)
	     (if (definedp name1 alist)
		 (cons name1 val)
		 f)
	     (assoc name1 alist)))
  ((do-not-induct t)
   (enable definedp-assoc-fact-1)))

(disable assoc-put-assoc-3)

(prove-lemma ADPP-LESSP-OFFSET-DEPOSIT (rewrite)
  (implies (and (lessp offset (length (cdr (assoc name data-seg))))
		(definedp name data-seg))
	   (lessp offset
		  (length (cdr (assoc name
				      (deposit anything
					       anywhere
					       data-seg))))))
  ((enable deposit
	   assoc-put-assoc-3
	   my-length-put)))

(prove-lemma ADPP-DEPOSIT-ANYTHING-AT-ALL (rewrite)
  (implies (adpp adp data-seg)
	   (adpp adp (deposit anything addr2 data-seg))))

(disable adpp-lessp-offset-deposit)
(disable adpp-deposit-anything-at-all)

(prove-lemma ADPP-UNTAG-DEFINEDP-AREA-NAME (rewrite)
  (implies (adpp (untag addr) data-seg)
	   (definedp (area-name addr) data-seg))
  ((enable area-name)))

(disable adpp-untag-definedp-area-name)

(prove-lemma ADPP-CONS-PACK-DEFINEDP-AREA-NAME (rewrite)
  (implies (adpp (cons (pack xxx) offset) data-seg)
	   (definedp (pack xxx) data-seg))
  ((enable area-name)))

(prove-lemma ADPP-UNTAG-NUMBERP-OFFSET (rewrite)
  (implies (adpp (untag addr) data-seg)
	   (numberp (offset addr)))
  ((enable offset)))

(disable adpp-untag-numberp-offset)

(prove-lemma ADPP-UNTAG-LISTP (rewrite)
  (implies (adpp (untag addr) data-seg)
	   (listp (untag addr)))
  ((enable offset)))

(disable adpp-untag-listp)

(prove-lemma ADPP-ADD-ADDR-0 (rewrite)
  (implies (and (adpp (untag addr) data-seg)
		(equal (cddr addr) nil)
		(equal (type addr) 'addr)
		(zerop n))
	   (equal (add-addr addr n) addr))
  ((enable adpp add-addr tag type untag)))

(disable adpp-add-addr-0)

(prove-lemma ADPP-UNTAG-LESSP-OFFSET (rewrite)
  (implies (adpp (untag addr) data-seg)
	   (lessp (offset addr) (length (cdr (assoc (area-name addr)
						    data-seg)))))
  ((enable area-name offset)))

(disable adpp-untag-lessp-offset)

(prove-lemma ADPP-SAME-SIGNATURE ()
  (implies (same-signature data-seg2 data-seg1)
	   (equal (adpp adp data-seg2)
		  (adpp adp data-seg1)))
  ((enable same-signature-implies-equal-lengths
	   same-signature-implies-equal-definedp)))

(disable adpp)

(prove-lemma P-OBJECTP-SIMILAR-P-STATES (rewrite)
  (implies (and (p-objectp object p0)
		(same-signature (p-data-segment p0) (p-data-segment p1))
		(equal (p-prog-segment p0) (p-prog-segment p1))
		(equal (p-word-size p0) (p-word-size p1)))
	   (p-objectp object p1))
  ((enable p-objectp
	   same-signature-implies-equal-definedp)
   (use (adpp-same-signature (adp (untag object))
			     (data-seg2 (p-data-segment p0))
			     (data-seg1 (p-data-segment p1))))
   (disable adpp bit-vectorp booleanp definedp pcpp
	    small-naturalp small-integerp)))

(prove-lemma ALL-P-OBJECTPS-LR->P-SIMILAR-STATES (rewrite)
  (implies (and (all-p-objectps lst p0)
		(equal (p-word-size p0) (p-word-size p1))
		(equal (p-prog-segment p0) (p-prog-segment p1))
		(same-signature (p-data-segment p0) (p-data-segment p1)))
	   (all-p-objectps lst p1)))

(prove-lemma PROPER-P-DATA-SEGMENTP-LR->P-SIMILAR-STATES (rewrite)
  (implies (and (proper-p-data-segmentp data-seg p0)
		(equal (p-word-size p0) (p-word-size p1))
		(equal (p-prog-segment p0) (p-prog-segment p1))
		(same-signature (p-data-segment p0) (p-data-segment p1)))
	   (proper-p-data-segmentp data-seg p1)))

(prove-lemma PROPER-P-TEMP-VAR-DCLSP-LR->P-SIMILAR-STATES (rewrite)
  (implies (and (proper-p-temp-var-dclsp temp-var-dcls p0)
		(equal (p-word-size p0) (p-word-size p1))
		(equal (p-prog-segment p0) (p-prog-segment p1))
		(same-signature (p-data-segment p0) (p-data-segment p1)))
	   (proper-p-temp-var-dclsp temp-var-dcls p1)))

(prove-lemma PROPER-P-INSTRUCTIONP-SIMILAR-P-STATES (rewrite)
  (implies (and (proper-p-instructionp ins name p0)
		(same-signature (p-data-segment p0) (p-data-segment p1))
		(equal (p-prog-segment p0) (p-prog-segment p1))
		(equal (p-word-size p0) (p-word-size p1)))
	   (proper-p-instructionp ins name p1))
  ((enable proper-p-instructionp
	   same-signature-implies-equal-definedp)))

(prove-lemma PROPER-LABELED-P-INSTRUCTIONSP-LR->P-SIMILAR-STATES (rewrite)
  (implies (and (proper-labeled-p-instructionsp lst name p0)
		(same-signature (p-data-segment p0) (p-data-segment p1))
		(equal (p-prog-segment p0) (p-prog-segment p1))
		(equal (p-word-size p0) (p-word-size p1)))
	   (proper-labeled-p-instructionsp lst name p1)))

(prove-lemma PROPER-P-PROG-SEGMENTP-LR->P-SIMILAR-STATES (rewrite)
  (implies (and (proper-p-prog-segmentp programs p0)
		(same-signature (p-data-segment p0) (p-data-segment p1))
		(equal (p-prog-segment p0) (p-prog-segment p1))
		(equal (p-word-size p0) (p-word-size p1)))
	 (proper-p-prog-segmentp programs p1))
  ((disable fall-off-proofp proper-p-temp-var-dclsp)))

(prove-lemma PROPER-P-TEMP-STKP-LR->P-SIMILAR-STATES (rewrite)
  (implies (and (proper-p-temp-stkp temp-stk p0)
		(same-signature (p-data-segment p0) (p-data-segment p1))
		(equal (p-prog-segment p0) (p-prog-segment p1))
		(equal (p-word-size p0) (p-word-size p1)))
	   (proper-p-temp-stkp temp-stk p1)))

(prove-lemma PROPER-P-ALISTP-LR->P-SIMILAR-STATES (rewrite)
  (implies (and (proper-p-alistp bindings p0)
		(same-signature (p-data-segment p0) (p-data-segment p1))
		(equal (p-prog-segment p0) (p-prog-segment p1))
		(equal (p-word-size p0) (p-word-size p1)))
	   (proper-p-alistp bindings p1)))

(prove-lemma PROPER-P-CTRL-STKP-LR->P-SIMILAR-STATES (rewrite)
  (implies (and (proper-p-ctrl-stkp ctrl-stk name p0)
		(same-signature (p-data-segment p0) (p-data-segment p1))
		(equal (p-prog-segment p0) (p-prog-segment p1))
		(equal (p-word-size p0) (p-word-size p1)))
	   (proper-p-ctrl-stkp ctrl-stk name p1)))

;; Now we prove what the result of running the SUBRPs.  We
;; start with a sample state (that the rewriter can match with
;; P-APPLY-SUBR-STATE) and run it.  We are only interested in TEMP-STK and
;; DATA-SEGMENT of the result.  However the running of the Piton code can
;; be a bit tedious, so we try and prove both parts at once with the
;; following function P-GOOD-RESULTP.  This also has the not ERRORP check
;; inside of it so that we should only have one instance of the Piton
;; interpreter (P) in each theorem.  This should hopefully reduce the time
;; (and pain) of proving these theorems.
(defn P-GOOD-RESULTP (p data-seg temp-stk ctrl-stk pc)
  (if (not (equal (p-psw p) 'run))
      t
      (and (equal (p-data-segment p) data-seg)
	   (equal (p-temp-stk p) temp-stk)
	   (listp ctrl-stk)
	   (equal (p-ctrl-stk p) ctrl-stk)
	   (equal (p-pc p) pc))))

(prove-lemma ASSOC-APPEND-1 (rewrite)
  (equal (assoc x (append list1 list2))
	 (if (definedp x list1)
	     (assoc x list1)
	     (assoc x list2))))

(disable assoc-append-1)

(prove-lemma LR-PROGRAMS-PROPERP-1-ALL-USER-FNAMESP-NOT-USER-FNAMEP (rewrite)
  (implies (and (all-user-fnamesp (strip-cars programs))
		(not (user-fnamep x)))
	   (not (definedp x programs))))

(prove-lemma DEFINITIONS-SUBRPS-LR-PROGRAMS-PROPERP (rewrite)
  (implies (lr-programs-properp l table)
	   (and (equal (assoc 'car (comp-programs (p-prog-segment l)))
		       (p-car-code))
		(equal (assoc 'cdr (comp-programs (p-prog-segment l)))
		       (p-cdr-code))
		(equal (assoc 'cons (comp-programs (p-prog-segment l)))
		       (p-cons-code))
		(equal (assoc 'false (comp-programs (p-prog-segment l)))
		       (p-false-code))
		(equal (assoc 'falsep (comp-programs (p-prog-segment l)))
		       (p-falsep-code))
		(equal (assoc 'listp (comp-programs (p-prog-segment l)))
		       (p-listp-code))
		(equal (assoc 'nlistp (comp-programs (p-prog-segment l)))
		       (p-nlistp-code))
		(equal (assoc 'true (comp-programs (p-prog-segment l)))
		       (p-true-code))
		(equal (assoc 'truep (comp-programs (p-prog-segment l)))
		       (p-truep-code))))
  ((enable comp-programs name lr-programs-properp
	   assoc-append-1)
   (disable comp-programs-1)))

(disable lr-programs-properp-1-all-user-fnamesp-not-user-fnamep)
(disable definitions-subrps-lr-programs-properp)

;; and now some openers for p-good-resultp
(prove-lemma P-GOOD-RESULTP-P-STATE-OPENER (rewrite)
  (equal (p-good-resultp (p-state pc
				  ctrl-stk
				  temp-stk
				  prog-seg
				  data-seg
				  max-ctrl-stk-size
				  max-temp-stk-size
				  word-size
				  'run)
			 result-data-seg
			 result-temp-stk
			 result-ctrl-stk
			 result-pc)
	 (and (equal data-seg result-data-seg)
	      (equal temp-stk result-temp-stk)
	      (listp result-ctrl-stk)
	      (equal ctrl-stk result-ctrl-stk)
	      (equal pc result-pc))))

(prove-lemma P-GOOD-RESULTP-P-HALT-ERRORP-OPENER (rewrite)
  (implies (not (equal psw 'run))
	   (p-good-resultp (p-halt p psw) data-seg temp-stk ctrl-stk pc)))

(disable P-GOOD-RESULTP)

(prove-lemma ALL-P-OBJECTPS-BAD-TYPE (rewrite)
  (implies (and (not (equal (get offset lst)
			    (list (type (get offset lst))
				  (untag (get offset lst)))))
		(numberp offset)
		(lessp offset (length lst)))
	   (not (all-p-objectps lst p)))
  ((enable get p-objectp type untag)
   (disable booleanp bit-vectorp pcpp small-integerp
	    small-naturalp *1*p-runtime-support-programs
	    p-objectp-opener)))

(prove-lemma PROPER-P-DATA-SEGMENTP-BAD-TYPE ()
  (implies (and (not (equal (fetch addr data-seg)
			    (list (type (fetch addr data-seg))
				  (untag (fetch addr data-seg)))))
		(adpp (untag addr) data-seg))
	   (not (proper-p-data-segmentp data-seg p)))
  ((enable adpp fetch
	   definedp-assoc-fact-1
	   get-anything-nil)))

(prove-lemma P-CURRENT-PROGRAM-P-STATE (rewrite)
  (equal (p-current-program (p-state pc
				     ctrl-stk
				     temp-stk
				     prog-seg
				     data-seg
				     max-ctrl-stk-size
				     max-temp-stk-size
				     word-size
				     psw))
	 (assoc (area-name pc) prog-seg))
  ((enable p-current-program)))

(prove-lemma P-CURRENT-INSTRUCTION-OPENER (rewrite)
  (equal (p-current-instruction (p-state pc
					 temp-stk
					 ctrl-stk
					 prog-segment
					 data-segment
					 max-ctrl-stk-size
					 max-temp-stk-size
					 word-size
					 psw))
	 (unlabel (get (offset pc) (program-body (assoc (area-name pc)
							prog-segment)))))
  ((enable p-current-instruction p-current-program)))

(disable p-current-instruction-opener)

(prove-lemma FETCH-DEPOSIT (rewrite)
  (implies (and (numberp (offset addr1))
		(numberp (offset addr2)))
	   (equal (fetch addr1 (deposit value addr2 data-seg))
		  (if (definedp (area-name addr2) data-seg)
		      (if (equal (area-name addr1) (area-name addr2))
			  (if (equal (offset addr1) (offset addr2))
			      value
			      (fetch addr1 data-seg))
			  (fetch addr1 data-seg))
		      (fetch addr1 data-seg))))
  ((enable adpp area-name deposit fetch offset type untag
	   assoc-put-assoc-3
	   definedp-assoc-fact-1
	   get-anything-nil
	   my-get-put)))

;; add-addr
(prove-lemma AREA-NAME-ADD-ADDR (rewrite)
  (equal (area-name (add-addr addr n)) (area-name addr))
  ((enable area-name add-addr)))

(prove-lemma OFFSET-ADD-ADDR (rewrite)
  (equal (offset (add-addr addr n)) (plus (offset addr) n))
  ((enable offset add-addr)))

(prove-lemma ADP-NAME-UNTAG-ADD-ADDR (rewrite)
  (equal (adp-name (untag (add-addr addr n))) (area-name addr))
  ((enable area-name untag add-addr tag)))

(prove-lemma ADD-ADDR-OF-NON-NUMBER (rewrite)
  (implies (not (numberp n))
	   (equal (add-addr addr n) (add-addr addr 0)))
  ((enable add-addr)))

(prove-lemma ADD-ADDR-ADD-ADDR (rewrite)
  (equal (add-addr (add-addr addr n) m) (add-addr addr (plus n m)))
  ((enable add-addr)))

(prove-lemma LISTP-UNTAG-ADD-ADDR (rewrite)
  (listp (untag (add-addr addr n)))
  ((enable add-addr)))

(prove-lemma TYPE-ADD-ADDR (rewrite)
  (equal (type (add-addr addr n)) (type addr))
  ((enable add-addr)))

(prove-lemma CDDR-ADD-ADDR (rewrite)
  (equal (cddr (add-addr addr n)) nil)
  ((enable add-addr)))

(prove-lemma AREA-NAME-LR-RETURN-PC (rewrite)
  (equal (area-name (lr-return-pc l)) (area-name (p-pc l)))
  ((enable lr-return-pc)))

(prove-lemma LISTP-UNTAG-LR-RETURN-PC (rewrite)
  (listp (untag (lr-return-pc l)))
  ((enable lr-return-pc)))

(prove-lemma TYPE-LR-RETURN-PC (rewrite)
  (equal (type (lr-return-pc l)) 'pc)
  ((enable lr-return-pc)))

(prove-lemma CDDR-LR-RETURN-PC (rewrite)
  (equal (cddr (lr-return-pc l)) nil)
  ((enable lr-return-pc)))

(prove-lemma NUMBERP-OFFSET-RETURN-PC (rewrite)
  (numberp (offset (lr-return-pc l)))
  ((enable lr-return-pc)))

(prove-lemma NUMBERP-CDR-UNTAG-RETURN-PC (rewrite)
  (numberp (cdr (untag (lr-return-pc l))))
  ((enable offset)
   (use (numberp-offset-return-pc (l l)))
   (disable numberp-offset-return-pc)))

(prove-lemma CAR-UNTAG-LR-RETURN-PC (rewrite)
  (equal (car (untag (lr-return-pc l))) (car (untag (p-pc l))))
  ((enable area-name)
   (use (area-name-lr-return-pc (l l)))
   (disable area-name-lr-return-pc)))

;; sub-addr
(prove-lemma AREA-NAME-SUB-ADDR (rewrite)
  (equal (area-name (sub-addr addr n)) (area-name addr))
  ((enable area-name sub-addr)))

(prove-lemma CDDR-SUB-ADDR (rewrite)
  (equal (cddr (sub-addr addr n)) nil)
  ((enable sub-addr)))

(prove-lemma TYPE-SUB-ADDR (rewrite)
  (equal (type (sub-addr addr n)) (type addr))
  ((enable sub-addr)))

(prove-lemma LISTP-UNTAG-SUB-ADDR (rewrite)
  (listp (untag (sub-addr addr n)))
  ((enable sub-addr)))

(prove-lemma OFFSET-SUB-ADDR (rewrite)
  (equal (offset (sub-addr addr n)) (difference (offset addr) n))
  ((enable offset sub-addr)))

;; LR-BOUNDARY-NODEP
(prove-lemma LR-BOUNDARY-NODEP-SUB-ADDR (rewrite)
  (implies (lr-boundary-nodep addr)
	   (lr-boundary-nodep (sub-addr addr (identity (lr-node-size)))))
  ((disable difference-add1-arg2)))

(prove-lemma LR-BOUNDARY-NODEP-ADD-ADDR-LR-NODE-SIZE (rewrite)
  (implies (lr-boundary-nodep addr)
	   (lr-boundary-nodep (add-addr addr (identity (lr-node-size)))))
  ((enable lr-boundary-nodep)))

(disable lr-boundary-nodep)

;; LR-NODEP
(prove-lemma LR-NODEP-OPENER (rewrite)
  (equal (lr-nodep addr data-seg)
	 (and (equal (type addr) 'addr)
	      (equal (cddr addr) nil)
	      (listp addr)
	      (adpp (untag addr) data-seg)
	      (lr-boundary-nodep addr)
	      (equal (area-name addr) (identity (lr-heap-name))))))

(disable lr-nodep)

;; LR-GOOD-POINTERP
(prove-lemma LR-GOOD-POINTERP-OPENER (rewrite)
  (equal (lr-good-pointerp addr data-seg)
	 (and (equal (type addr) 'addr)
	      (equal (cddr addr) nil)
	      (listp addr)
	      (adpp (untag addr) data-seg)
	      (lr-boundary-nodep addr)
	      (equal (area-name addr) (identity (lr-heap-name)))
	      (equal (type (fetch (add-addr addr
					    (identity
					     (lr-ref-count-offset)))
				  data-seg))
		     'nat))))

(disable lr-good-pointerp)

(prove-lemma EQUAL-PLUS-REMAINDER-0-FACT ()
  (implies (and (equal (remainder offset1 max) 0)
		(equal (remainder offset2 max) 0)
		(lessp n max)
		(lessp m max)
		(numberp offset1)
		(numberp offset2))
	   (equal (equal (plus n offset1) (plus m offset2))
		  (and (equal (fix n) (fix m))
		       (equal offset1 offset2))))
  ((disable-theory addition remainders)
   (enable correctness-of-cancel-equal-plus commutativity-of-plus
	   remainder-noop remainder-zero)
   (induct (double-remainder-induction offset1 offset2 max))))

(prove-lemma LR-BOUNDARY-OFFSETP-EQUAL-PLUS-FACT (rewrite)
  (implies (and (lr-boundary-offsetp offset1)
		(lr-boundary-offsetp offset2)
		(lessp n (lr-node-size))
		(lessp m (lr-node-size))
		(numberp offset1)
		(numberp offset2))
	   (equal (equal (plus n offset1) (plus m offset2))
		  (and (equal (fix n) (fix m))
		       (equal offset1 offset2))))
  ((disable-theory addition quotients)
   (use (equal-plus-remainder-0-fact (offset1 offset1)
				     (offset2 offset2)
				     (max (lr-node-size))
				     (n n)
				     (m m)))))

(prove-lemma GOOD-POSP-LIST-NX-T-SIMPLE (rewrite)
  (implies (and (good-posp 'list pos body)
		(listp pos)
		(lessp (car (last pos))
		       (length (cur-expr (butlast pos) body))))
	   (and (good-posp 'list (nx pos) body)
		(good-posp1 pos body)))
  ((enable good-posp)))

(prove-lemma LR-PROGRAMS-PROPERP-1-LR-PROPER-EXPRP ()
  (implies (and (lr-programs-properp-1 progs program-names table)
		(member prog progs))
	   (lr-proper-exprp t
			   (program-body prog)
			   program-names
			   (formal-vars prog)
			   (strip-cars (temp-var-dcls prog))
			   table))
  ((disable lr-proper-exprp)
   (enable lr-programs-properp-1)))

(prove-lemma LR-PROPER-EXPRP-LIST-LR-PROPER-GET-T (rewrite)
  (implies (lr-proper-exprp 'list expr pnames formals temps table)
	   (equal (lr-proper-exprp t
				   (get n expr)
				   pnames formals temps table)
		  (lessp n (length expr))))
  ((enable get
	   get-anything-nil)
   (induct (get n expr))))

(prove-lemma LR-PROPER-EXPRP-T-LR-PROPER-GET-T (rewrite)
  (implies (and (not (equal (car expr) (s-temp-fetch)))
		(not (equal (car expr) (s-temp-eval)))
		(not (equal (car expr) (s-temp-test)))
		(not (equal (car expr) 'quote))
		(not (zerop n))
		(lr-proper-exprp t expr pnames formals temps table))
	   (equal (lr-proper-exprp t
				   (get n expr)
				   pnames formals temps table)
		  (lessp n (length expr))))
  ((enable get-anything-nil get-cons)
   (disable *1*p-runtime-support-programs)
   (expand (lr-proper-exprp t expr pnames formals temps table))))

(disable lr-proper-exprp-list-lr-proper-get-t)

(prove-lemma LR-PROPER-EXPRP-LR-PROPER-EXPRP-CUR-EXPR ()
  (implies (and (lr-proper-exprp t body pnames formals temps table)
		(good-posp1 pos body))
	   (lr-proper-exprp t
			    (cur-expr pos body)
			    pnames formals temps table))
  ((enable good-posp1)))

(prove-lemma LR-PROGRAMS-PROPERP-LR-PROGRAMS-PROPERP-1 (rewrite)
  (implies (and (lr-programs-properp l table)
		(equal prog-seg (p-prog-segment l)))
	   (and (lr-programs-properp-1 (p-prog-segment l)
				       (strip-logic-fnames (cdr prog-seg))
				       table)
		(definedp (area-name (p-pc l)) prog-seg)))
  ((enable lr-programs-properp)))

(prove-lemma LR-PROGRAMS-PROPERP-LR-PROPER-EXPRP-LR-EXPR ()
  (implies (and (lr-programs-properp l table)
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l))))
	   (lr-proper-exprp t
			    (lr-expr l)
			    (strip-logic-fnames (cdr (p-prog-segment l)))
			    (formal-vars (p-current-program l))
			    (strip-cars (temp-var-dcls
					 (p-current-program l)))
			    table))
  ((use (lr-programs-properp-1-lr-proper-exprp
	 (prog (p-current-program l))
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))
	 (progs (p-prog-segment l))
	 (table table))
	(lr-proper-exprp-lr-proper-exprp-cur-expr
	 (body (program-body (p-current-program l)))
	 (pnames (strip-logic-fnames (cdr (p-prog-segment l))))
	 (formals (formal-vars (p-current-program l)))
	 (temps (strip-cars (temp-var-dcls (p-current-program l))))
	 (pos (offset (p-pc l)))
	 (table table)))
   (enable cur-expr lr-expr strip-cars p-current-program
	   good-posp1-list-good-posp-list-t)
   (disable lr-proper-exprp)))

(prove-lemma LR-PROPER-EXPRP-LENGTH-CUR-EXPR ()
  (implies (and (lr-proper-exprp t expr pnames formals temps table)
		(listp expr)
		(or (subrp (car expr)) (body (car expr)))
		(not (equal (car expr) 'quote)))
	   (equal (length expr) (add1 (arity (car expr)))))
  ((disable lr-proper-exprp
	    *1*p-runtime-support-programs)
   (expand (lr-proper-exprp t expr pnames formals temps table))))

(prove-lemma LISTP-COMP-BODY-1 (rewrite)
  (equal (listp (comp-body-1 flag body n))
	 (if (equal flag 'list)
	     (listp body)
	     t))
  ((induct (comp-body-1 flag body n))
   (disable comp-if comp-temp-test)
   (expand (comp-body-1 flag body n)
	   (comp-body-1 'list body n))))

(prove-lemma CAR-APPEND (rewrite)
  (implies (listp x)
	   (equal (car (append x y)) (car x))))

(prove-lemma LENGTH-CDR-COMP-IF-COMP-BODY (rewrite)
  (equal (length (comp-if (comp-body-1 t test n1)
			  (comp-body-1 t then n2)
			  (comp-body-1 t else n3)
			  n))
	 (plus (length (comp-body-1 t test n1))
	       (length (comp-body-1 t then n2))
	       (length (comp-body-1 t else n3))
	       4)))

(prove-lemma LR-P-C-SIZE-LIST-0-OPENER (rewrite)
  (equal (lr-p-c-size-list 0 expr) 0))

(prove-lemma LR-P-C-SIZE-LIST-ADD1-OPENER (rewrite)
  (implies (lessp (add1 n) (length expr))
	   (equal (lr-p-c-size-list (add1 n) expr)
		  (plus (lr-p-c-size t (cadr expr))
			(lr-p-c-size-list n (cdr expr)))))
  ((expand (lr-p-c-size-list 1 expr))
   (induct (lr-p-c-size-list n expr))))

(prove-lemma LENGTH-COMP-BODY-1-LR-P-C-SIZE (rewrite)
  (equal (length (comp-body-1 flag body n))
	 (lr-p-c-size flag body))
  ((enable car-restn-get
	   get-add1-opener get-zerop)
   (induct (comp-body-1 flag body n))
   (disable comp-if lr-p-c-size lr-p-c-size-list)
   (expand (comp-body-1 flag body n) (comp-body-1 'list body n)
	   (lr-p-c-size flag body) (lr-p-c-size 'list body))))

(disable lr-p-c-size-list-add1-opener)

(prove-lemma LENGTH-LABEL-INSTRS (rewrite)
  (equal (length (label-instrs instrs n)) (length instrs)))

(prove-lemma LENGTH-COMP-BODY-LR-P-C-SIZE (rewrite)
  (equal (length (comp-body body)) (add1 (lr-p-c-size t body)))
  ((enable comp-body)
   (disable lr-p-c-size)))

(prove-lemma LR-P-C-SIZE-FLAG-LIST (rewrite)
  (equal (lr-p-c-size 'list (cdr expr))
	 (lr-p-c-size-list (sub1 (length expr)) expr))
  ((induct (length expr))
   (enable lr-p-c-size-list-add1-opener)
   (expand (lr-p-c-size-list 0 expr))
   (disable lr-p-c-size-list)))

(prove-lemma LR-PROPER-EXPRP-CAR-IF-CADR (rewrite)
  (implies (and (lr-proper-exprp t body pnames formals temps table)
		(listp body)
		(equal (car body) 'if))
	   (lr-proper-exprp t (cadr body) pnames formals temps table)))

(prove-lemma LR-PROPER-EXPRP-CAR-IF-CADDR (rewrite)
  (implies (and (lr-proper-exprp t body pnames formals temps table)
		(listp body)
		(equal (car body) 'if))
	   (lr-proper-exprp t (caddr body) pnames formals temps table)))

(prove-lemma LR-PROPER-EXPRP-CAR-IF-CADDDR (rewrite)
  (implies (and (lr-proper-exprp t body pnames formals temps table)
		(listp body)
		(equal (car body) 'if))
	   (lr-proper-exprp t (cadddr body) pnames formals temps table)))

(prove-lemma GOOD-POSP-LIST-T-OFFSET-PROGRAM-BODY (rewrite)
  (implies (and (good-posp 'list
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(listp (lr-expr-list l))
		(listp (offset (p-pc l))))
	   (good-posp1 (offset (p-pc l))
		       (program-body (p-current-program l))))
  ((enable good-posp lr-expr-list)
   (disable good-posp-list)))

(prove-lemma GOOD-POSP-LIST-NX-OFFSET-PROGRAM-BODY (rewrite)
  (implies (and (good-posp 'list
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(listp (offset (p-pc l)))
		(listp (lr-expr-list l)))
	   (good-posp 'list
		      (nx (offset (p-pc l)))
		      (program-body (p-current-program l))))
  ((enable good-posp lr-expr-list)))

(prove-lemma NAME-FORMAL-VARS-TEMP-VAR-DCLS-PROGRAM-BODY-CONS (rewrite)
  (and (equal (name (cons name rest)) name)
       (equal (formal-vars (cons name (cons formal-vars rest))) formal-vars)
       (equal (temp-var-dcls (cons name
				   (cons formal-vars
					 (cons temp-var-dcls
					       program-body))))
	      temp-var-dcls)
       (equal (program-body (cons name
				   (cons formal-vars
					 (cons temp-var-dcls
					       program-body))))
	      program-body))
  ((enable name formal-vars temp-var-dcls program-body)))

(prove-lemma PROGRAM-BODY-ASSOC-COMP-PROGRAMS-1 (rewrite)
  (implies (definedp name programs)
	   (equal (program-body (assoc name (comp-programs-1 programs)))
		  (comp-body (program-body (assoc name programs)))))
  ((enable name program-body)))

(prove-lemma PROGRAM-BODY-ASSOC-COMP-PROGRAMS (rewrite)
  (implies (definedp name programs)
	   (equal (program-body (assoc name (comp-programs programs)))
		  (if (equal name (name (car programs)))
		      (label-instrs
		       (append (comp-body-1 t
					    (program-body (car programs))
					    0)
			       (list (identity
				      (list 'SET-GLOBAL
					    (area-name (lr-answer-addr))))
				     '(RET)))
		       0)
		      (comp-body (program-body (assoc name
						      (cdr programs)))))))
  ((enable comp-programs name
	   assoc-append-1)
   (disable comp-programs-1)))

(prove-lemma DEFINEDP-AREA-NAME-MEMBER-P-CURRENT-PROGRAM (rewrite)
  (implies (definedp (area-name (p-pc l)) (p-prog-segment l))
	   (member (p-current-program l) (p-prog-segment l)))
  ((enable p-current-program)))

(defn INDUCT-HINT-6 (n body)
  (if (lessp n (length body))
      (induct-hint-6 (add1 n) body)
      t)
  ((lessp (difference (add1 (length body)) n))))

(prove-lemma LR-P-C-SIZE-LIST-0 (rewrite)
  (implies (listp body)
	   (equal (equal (lr-p-c-size-list n body) 0)
		  (or (zerop n)
		      (nlistp (cdr body))))))

(disable lr-p-c-size-list-0)

(prove-lemma LESSP-LR-P-C-SIZE-LIST-LESSP-SUB1-LENGTH (rewrite)
  (implies (not (equal (lr-p-c-size-list n body) 0))
	   (lessp (sub1 (lr-p-c-size-list n body))
		  (lr-p-c-size-list (sub1 (length body)) body)))
  ((induct (induct-hint-6 n body))
   (enable lr-p-c-size-list-0)))

(prove-lemma LR-P-PC-1-BODY-0 (rewrite)
  (equal (lr-p-pc-1 0 pos) 0))

(prove-lemma LESSP-LR-P-PC-1-LR-P-C-SIZE-HELPER-1 (rewrite)
  (implies (and (listp body)
		(not (zerop n))
		(lessp (lr-p-pc-1 (get n body) pos)
		       (lr-p-c-size t (get n body)))
		(not (equal (lr-p-pc-1 (get n body) pos) 0)))
	   (lessp (sub1 (plus (lr-p-c-size-list (sub1 n) body)
			      (lr-p-pc-1 (get n body) pos)))
		  (lr-p-c-size-list (sub1 (length body)) body)))
  ((use (lessp-lr-p-c-size-list-lessp-sub1-length (n n) (body body)))
   (enable get-large-index
	   lr-p-c-size-list-0)
   (expand (lr-p-c-size-list n body))
   (disable lr-p-c-size-list lr-p-pc-1
	    lessp-lr-p-c-size-list-lessp-sub1-length)))

(prove-lemma LESSP-LR-P-PC-1-LR-P-C-SIZE (rewrite)
  (lessp (lr-p-pc-1 body pos) (lr-p-c-size t body))
  ((induct (lr-p-pc-1 body pos))
   (expand (lr-p-pc-1 body pos) (lr-p-c-size t body))
   (disable lr-p-pc-1 lr-p-c-size lr-p-c-size-list)))

(disable lessp-lr-p-pc-1-lr-p-c-size-helper-1)

(prove-lemma NOT-LESSP-P-MAX-TEMP-STK-SIZE-LR-PUSH-TSTK (rewrite)
  (implies (equal (p-psw (lr-push-tstk l anything)) 'run)
	   (not (lessp (p-max-temp-stk-size l)
		       (length (p-temp-stk (lr-push-tstk l anything))))))
  ((enable lr-push-tstk)))

(prove-lemma PROPER-P-TEMP-STKP-LR->P-LR-PUSH-TSTK (rewrite)
  (equal (proper-p-temp-stkp temp-stkp (lr->p (lr-push-tstk l anything)))
	 (proper-p-temp-stkp temp-stkp (lr->p l))))

(prove-lemma PROPER-P-ALISTP-P-OBJECTP ()
  (implies (and (proper-p-alistp bindings l)
		(definedp name bindings))
	   (p-objectp (cdr (assoc name bindings)) l)))

(prove-lemma FORMAL-VARS-ASSOC-COMP-PROGRAMS-1 (rewrite)
  (implies (definedp name programs)
	   (equal (formal-vars (assoc name (comp-programs-1 programs)))
		  (formal-vars (assoc name programs))))
  ((enable formal-vars name)))

(prove-lemma FORMAL-VARS-ASSOC-COMP-PROGRAMS (rewrite)
  (implies (definedp name programs)
	   (equal (formal-vars (assoc name (comp-programs programs)))
		  (formal-vars (assoc name programs))))
  ((enable comp-programs name
	   assoc-append-1)
   (disable comp-programs-1
	    *1*p-runtime-support-programs)))

(prove-lemma TEMP-VAR-DCLS-ASSOC-COMP-PROGRAMS-1 (rewrite)
  (implies (definedp name programs)
	   (equal (temp-var-dcls (assoc name (comp-programs-1 programs)))
		  (temp-var-dcls (assoc name programs))))
  ((enable temp-var-dcls name)))

(prove-lemma TEMP-VAR-DCLS-ASSOC-COMP-PROGRAMS (rewrite)
  (implies (definedp name programs)
	   (equal (temp-var-dcls (assoc name (comp-programs programs)))
		  (temp-var-dcls (assoc name programs))))
  ((enable comp-programs name
	   assoc-append-1)
   (disable comp-programs-1
	    *1*p-runtime-support-programs)))

(prove-lemma LR-PROGRAMS-PROPERP-DEFINEDP-CAR-UNTAG-P-PC (rewrite)
  (implies (lr-programs-properp l table)
	   (definedp (car (untag (p-pc l))) (p-prog-segment l)))
  ((enable area-name lr-programs-properp)))

(prove-lemma P-OBJECTP-CDR-ASSOC-LITATOM-PROPER-P-ALISTP (rewrite)
  (implies (and (proper-p-alistp bindings lp)
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (strip-cars bindings)
		       (append
			(formal-vars
			 (assoc (car (untag (p-pc l)))
				(comp-programs-1 (p-prog-segment l))))
			(strip-cars
			 (temp-var-dcls
			  (assoc (car (untag (p-pc l)))
				 (comp-programs-1 (p-prog-segment l)))))))
		(litatom (lr-expr l)))
	   (p-objectp (cdr (assoc (lr-expr l) bindings)) lp))
  ((enable area-name lr-expr p-current-program)
   (use (lr-programs-properp-lr-proper-exprp-lr-expr (l l) (table table))
	(proper-p-alistp-p-objectp (bindings bindings)
				   (l lp)
				   (name (lr-expr l)))
	(member-strip-cars-definedp (x (lr-expr l)) (y bindings))
	(member-append
	 (a (lr-expr l))
	 (y (strip-cars (temp-var-dcls (p-current-program l))))
	 (x (formal-vars (p-current-program l)))))
   (disable comp-programs-1 cur-expr
	    member-append
	    p-objectp-opener)))

(prove-lemma PROPER-P-TEMP-STKP-LR-PUSH-TSTK-ASSOC-BINDINGS (rewrite)
  (implies (and (lr-programs-properp l table)
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(proper-p-alistp (bindings (car (p-ctrl-stk l))) (lr->p l))
		(litatom (lr-expr l))
		(equal
		 (strip-cars (bindings (car (p-ctrl-stk l))))
		 (append
		  (formal-vars (assoc (car (untag (p-pc l)))
				      (comp-programs-1 (p-prog-segment l))))
		  (strip-cars
		   (temp-var-dcls
		    (assoc (car (untag (p-pc l)))
			   (comp-programs-1 (p-prog-segment l))))))))
	   (equal
	    (proper-p-temp-stkp
	     (p-temp-stk
	      (lr-push-tstk l
			    (cdr (assoc (lr-expr l)
					(bindings (car (p-ctrl-stk l)))))))
	     (lr->p l))
	    (proper-p-temp-stkp (p-temp-stk l) (lr->p l))))
  ((enable lr-push-tstk)
   (disable comp-programs-1
	    *1*p-runtime-support-programs)))

(prove-lemma LR-P-PC-LR-PUSH-TSTK (rewrite)
  (equal (lr-p-pc (lr-push-tstk l anything)) (lr-p-pc l))
  ((enable lr-p-pc p-current-program)))

(prove-lemma PROPER-P-STATEP-LR->P-LR-PUSH-TSTK (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(lr-programs-properp l table)
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(equal (p-psw
			(lr-push-tstk
			 l
			 (cdr (assoc (lr-expr l)
				     (bindings (car (p-ctrl-stk l)))))))
		       'run)
		(litatom (lr-expr l)))
	   (proper-p-statep
	    (lr->p (lr-push-tstk
		    l
		    (cdr (assoc (lr-expr l)
				(bindings (car (p-ctrl-stk l)))))))))
  ((enable area-name p-current-program proper-p-statep)
   (disable definedp pcpp proper-p-prog-segmentp
	    *1*p-runtime-support-programs
	    proper-p-temp-stkp-lr-push-tstk-assoc-bindings)
   (use (proper-p-temp-stkp-lr-push-tstk-assoc-bindings (l l)
							(flag flag)))))

(prove-lemma GOOD-POSP1-CONS-LESSP-4-IF-LR-PROPER-EXPRP (rewrite)
  (implies (and (equal (car (cur-expr pos body)) 'if)
		(good-posp1 pos body)
		(lr-proper-exprp t body pnames formals temps table))
	   (and (good-posp1 (dv pos 1) body)
		(good-posp1 (dv pos 2) body)
		(good-posp1 (dv pos 3) body)))
  ((enable dv good-posp1)
   (use (lr-proper-exprp-length-cur-expr
	 (expr (cur-expr pos body))
	 (pnames pnames) (formals formals) (temps temps) (table table))
	(lr-proper-exprp-lr-proper-exprp-cur-expr
	 (body body) (pos pos)
	 (pnames pnames) (formals formals) (temps temps) (table table)))
   (disable lr-proper-exprp)))

(prove-lemma GOOD-POSP-CONS-LESSP-4-IF-LR-PROGRAMS-PROPERP (rewrite)
  (implies (and (equal (car (lr-expr l)) 'if)
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table))
	   (and (good-posp1 (dv (offset (p-pc l)) 1)
			    (program-body (p-current-program l)))
		(good-posp1 (dv (offset (p-pc l)) 2)
			    (program-body (p-current-program l)))
		(good-posp1 (dv (offset (p-pc l)) 3)
			    (program-body (p-current-program l)))))
  ((enable lr-expr p-current-program)
   (disable cur-expr lr-proper-exprp)
   (use (lr-programs-properp-1-lr-proper-exprp
	 (prog (p-current-program l))
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))
	 (progs (p-prog-segment l))
	 (table table)))))

(prove-lemma PROPER-P-STATEP-LR->P-LR-SET-POS (rewrite)
  (implies (and (lr-programs-properp l table)
		(proper-p-statep (lr->p l)))
	   (proper-p-statep (lr->p (lr-set-pos l pos))))
  ((enable adp-name area-name lr-p-pc lr-programs-properp name
	   proper-p-statep p-current-program)
   (disable lr-p-pc-1 proper-p-alistp proper-p-ctrl-stkp proper-p-temp-stkp
	    proper-p-prog-segmentp)))

(prove-lemma LR-P-PC-LR-POP-TSTK (rewrite)
  (equal (lr-p-pc (lr-pop-tstk l)) (lr-p-pc l))
  ((enable lr-p-pc p-current-program)))

(prove-lemma PROPER-P-STATEP-LR->P-LR-POP-TSTK (rewrite)
  (implies (proper-p-statep (lr->p l))
	   (proper-p-statep (lr->p (lr-pop-tstk l))))
  ((enable proper-p-statep)
   (disable exp p-ctrl-stk-size proper-p-alistp proper-p-ctrl-stkp
	    proper-p-data-segmentp proper-p-prog-segmentp)))

(prove-lemma GOOD-POSP-DV-1-TEMPS-LR-EXPR (rewrite)
  (implies (and (or (equal (car (lr-expr l)) (s-temp-eval))
		    (equal (car (lr-expr l)) (s-temp-test)))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l))))
	   (good-posp1 (dv (offset (p-pc l)) 1)
		       (program-body (p-current-program l))))
  ((enable dv lr-expr)
   (expand (good-posp1 '(1)
		       (cur-expr (offset (p-pc l))
				 (program-body (p-current-program l)))))))

(prove-lemma PROPER-P-ALISTP-PUT-ASSOC (rewrite)
  (implies (and (proper-p-alistp bindings l)
		(p-objectp object l))
	   (proper-p-alistp (put-assoc object var-name bindings) l)))

(prove-lemma LISTP-P-TEMP-STK-LR-PUSH-TSTK (rewrite)
  (implies (equal (p-psw (lr-push-tstk l object)) 'run)
	   (listp (p-temp-stk (lr-push-tstk l object))))
  ((enable lr-push-tstk)))

(prove-lemma LR-P-PC-LR-SET-TEMP (rewrite)
  (equal (lr-p-pc (lr-set-temp l value var-name)) (lr-p-pc l))
  ((enable lr-p-pc p-current-program)))

(prove-lemma PROPER-P-STATEP-LR-SET-TEMP (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(listp (p-temp-stk l)))
	   (proper-p-statep (lr->p (lr-set-temp l
						(car (p-temp-stk l))
						var-name))))
  ((enable proper-p-statep)
   (disable exp proper-p-alistp proper-p-ctrl-stkp proper-p-data-segmentp
	    proper-p-prog-segmentp proper-p-temp-stkp)
   (expand (proper-p-temp-stkp (p-temp-stk l)
			       (lr->p (lr-set-temp l
						   (car (p-temp-stk l))
						   var-name)))
	   (proper-p-temp-stkp (p-temp-stk l) (lr->p l)))))

(prove-lemma P-OBJECTP-CDR-ASSOC-BINDINGS-PROPER-P-ALISTP (rewrite)
  (implies (and (proper-p-alistp bindings l)
		(definedp object bindings))
	   (p-objectp (cdr (assoc object bindings)) l)))

(prove-lemma DEFINEDP-CADDR-LR-EXPR-BINDINGS-CTRL-STK ()
  (implies (and (lr-programs-properp-1 progs program-names table)
		(definedp name progs)
		(or (equal (car (cur-expr pos
					  (program-body (assoc name
							       progs))))
			   (s-temp-fetch))
		    (equal (car (cur-expr pos
					  (program-body (assoc name
							       progs))))
			   (s-temp-test)))
		(good-posp1 pos (program-body (assoc name progs)))
		(equal
		 (strip-cars bindings)
		 (append (formal-vars (assoc name (comp-programs progs)))
			 (strip-cars
			  (temp-var-dcls (assoc name
						(comp-programs progs)))))))
	   (definedp (caddr (cur-expr pos (program-body (assoc name
							       progs))))
		     bindings))
  ((use (lr-programs-properp-1-lr-proper-exprp
	 (prog (assoc name progs))
	 (program-names program-names) (progs progs) (table table))
	(lr-proper-exprp-lr-proper-exprp-cur-expr
	 (body (program-body (assoc name progs)))
	 (pnames program-names)
	 (formals (formal-vars (assoc name progs)))
	 (temps (strip-cars (temp-var-dcls (assoc name progs))))
	 (pos pos)
	 (table table))
	(member-strip-cars-definedp
	 (x (caddr (cur-expr pos (program-body (assoc name progs)))))
	 (y bindings))
	(member-append (a (caddr (cur-expr pos
					   (program-body (assoc name
								progs)))))
		       (x (formal-vars (assoc name progs)))
		       (y (strip-cars (temp-var-dcls (assoc name progs))))))
   (expand
    (lr-proper-exprp t
		     (cur-expr pos (program-body (assoc name progs)))
		     program-names
		     (formal-vars (assoc name progs))
		     (strip-cars (temp-var-dcls (assoc name progs)))
		     table))
   (disable lr-proper-exprp
	    *1*p-runtime-support-programs
	    member-append
	    lr-proper-exprp-lr-proper-exprp-cur-expr)))

(prove-lemma PROPER-P-TEMP-STKP-P-TEMP-STK-LR-DO-TEMP-FETCH (rewrite)
  (implies (and (proper-p-framep (top (p-ctrl-stk l1))
				 (area-name (p-pc l1))
				 l2)
		(lr-programs-properp l1 table)
		(or (equal (car (lr-expr l1)) (s-temp-fetch))
		    (equal (car (lr-expr l1)) (s-temp-test)))
		(good-posp1 (offset (p-pc l1))
			    (program-body (p-current-program l1)))
		(same-signature (p-data-segment l1) (p-data-segment l2))
		(equal (p-prog-segment (lr->p l1)) (p-prog-segment l2))
		(equal (p-word-size l1) (p-word-size l2)))
	   (equal (proper-p-temp-stkp (p-temp-stk (lr-do-temp-fetch l1)) l2)
		  (proper-p-temp-stkp (p-temp-stk l1) l2)))
  ((enable lr-expr lr-do-temp-fetch lr-push-tstk p-current-program)
   (disable cur-expr lr-proper-exprp)
   (use (definedp-caddr-lr-expr-bindings-ctrl-stk
	  (progs (p-prog-segment l1))
	  (program-names (strip-logic-fnames (cdr (p-prog-segment l1))))
	  (bindings (bindings (car (p-ctrl-stk l1))))
	  (name (area-name (p-pc l1)))
	  (pos (offset (p-pc l1)))))))

(prove-lemma LENGTH-LR-DO-TEMP-FETCH (rewrite)
  (implies (equal (p-psw (lr-do-temp-fetch l)) 'run)
	   (not (lessp (p-max-temp-stk-size l)
		       (length (p-temp-stk (lr-do-temp-fetch l))))))
  ((enable lr-do-temp-fetch)))

(prove-lemma LR-P-PC-LR-DO-TEMP-FETCH (rewrite)
  (equal (lr-p-pc (lr-do-temp-fetch l)) (lr-p-pc l))
  ((enable lr-p-pc p-current-program)))

(prove-lemma PROPER-P-STATEP-LR-DO-TEMP-FETCH (rewrite)
  (implies (and (equal (p-psw (lr-do-temp-fetch l)) 'run)
		(lr-programs-properp l table)
		(or (equal (car (lr-expr l)) (s-temp-fetch))
		    (equal (car (lr-expr l)) (s-temp-test)))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(proper-p-statep (lr->p l)))
	   (proper-p-statep (lr->p (lr-do-temp-fetch l))))
  ((enable proper-p-statep)
   (disable exp proper-p-alistp proper-p-ctrl-stkp proper-p-data-segmentp
	    proper-p-prog-segmentp proper-p-temp-stkp)))

(prove-lemma LENGTH-LR-PUSH-TSTK (rewrite)
  (implies (equal (p-psw (lr-push-tstk l object)) 'run)
	   (not (lessp (p-max-temp-stk-size l)
		       (length (p-temp-stk (lr-push-tstk l object))))))
  ((enable lr-push-tstk)))

(prove-lemma LISTP-P-TEMP-STK-LR-DO-TEMP-FETCH (rewrite)
  (implies (equal (p-psw (lr-do-temp-fetch l)) 'run)
	   (listp (p-temp-stk (lr-do-temp-fetch l))))
  ((enable lr-do-temp-fetch lr-push-tstk)))

(prove-lemma PROPER-P-PROG-SEGMENTP-APPEND (rewrite)
  (implies (plistp segment1)
	   (equal (proper-p-prog-segmentp (append segment1 segment2) p)
		  (and (proper-p-prog-segmentp segment1 p)
		       (proper-p-prog-segmentp segment2 p))))
  ((disable proper-p-programp)))

(prove-lemma LR-PROGRAMS-PROPERP-EXPR-QUOTE-TYPE-ADDR ()
  (implies (and (lr-programs-properp l table)
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(listp (lr-expr l))
		(equal (car (lr-expr l)) 'quote))
	   (equal (type (cadr (lr-expr l))) 'addr))
  ((use (lr-programs-properp-lr-proper-exprp-lr-expr (l l) (table table)))))

(prove-lemma PROPER-P-INSTRUCTIONP-PUSH-CONSTANT-OPENER (rewrite)
  (equal (proper-p-instructionp (list 'push-constant object) name p)
	 (proper-p-push-constant-instructionp (list 'push-constant object)
					      name
					      p))
  ((enable proper-p-instructionp)))

(prove-lemma PROPER-LABELED-P-INSTRUCTIONSP-FIND-LABELP-NON-LITATOM ()
  (implies (and (proper-labeled-p-instructionsp body name p)
		(not (litatom label)))
	   (equal (find-labelp label body) f))
  ((enable legal-labelp)))

(prove-lemma LESSP-4-NOT-ZEROP-NOT-1-NOT-2-3 ()
  (implies (and (not (zerop n))
		(not (equal n 1))
		(not (equal n 2))
		(lessp n 4))
	   (equal n 3)))

(prove-lemma LESSP-4-NOT-ZEROP-NOT-1-NOT-2-3-GET-CAR-POS (rewrite)
  (implies (and (not (zerop (car pos)))
		(not (equal (car pos) 1))
		(not (equal (car pos) 2))
		(lessp (car pos) 4))
	   (equal (get (car pos) body) (cadddr body)))
  ((use (lessp-4-not-zerop-not-1-not-2-3 (n (car pos))))))

(disable lessp-4-not-zerop-not-1-not-2-3-get-car-pos)

(prove-lemma LESSP-INDEX-LESSP-LR-P-C-SIZE-LIST ()
  (not (lessp (lr-p-c-size-list (length (cdr body)) body)
	      (lr-p-c-size-list n body)))
  ((disable lr-p-c-size)))

(prove-lemma LESSP-PLUS-LR-P-C-SIZE-LR-P-PC-1-HELPER (rewrite)
  (implies (and (listp body)
		(not (zerop n))
		(not (lessp (lr-p-c-size t (get n body)) x))
		(lessp (sub1 n) (length (cdr body)))
		(equal len (length (cdr body))))
	   (equal (lessp (plus (lr-p-c-size-list len body) 1)
			 (plus (lr-p-c-size-list (sub1 n) body) x))
		  f))
  ((enable lr-p-c-size-list-0)
   (use (lessp-index-lessp-lr-p-c-size-list (n n) (body body)))
   (expand (lr-p-c-size-list n body))
   (disable lr-p-c-size lr-p-c-size-list lr-p-pc-1)))

(prove-lemma LESSP-PLUS-LR-P-C-SIZE-LR-P-PC-1 (rewrite)
  (implies (and (good-posp1 pos body)
		(lr-proper-exprp t body pnames formals temps table))
	   (not (lessp (lr-p-c-size t body)
		       (plus (lr-p-pc-1 body pos)
			     (lr-p-c-size t (cur-expr pos body))))))
  ((induct (lr-p-pc-1 body pos))
   (enable associativity-of-plus
	   get-anything-nil
	   lessp-4-not-zerop-not-1-not-2-3-get-car-pos)
   (expand (lr-p-pc-1 body pos)
	   (cur-expr pos body)
	   (lr-p-c-size t body)
	   (good-posp1 pos body)
	   (lr-proper-exprp t body pnames formals temps table))
   (disable cur-expr lr-p-pc-1 lr-p-c-size lr-p-c-size-list
	    lr-proper-exprp)
   (disable-theory addition)))

(defn INDUCT-HINT-7 (pos expr n)
  (cond ((nlistp pos) t)
	((nlistp expr) t)
	((equal (car expr) 'if)
	 (let ((then-n (plus n 3 (lr-p-c-size t (cadr expr)))))
	   (case (car pos)
	     (1 (induct-hint-7 (cdr pos) (cadr expr) n))
	     (2 (induct-hint-7 (cdr pos) (caddr expr) then-n))
	     (otherwise
	      (induct-hint-7 (cdr pos) (cadddr expr)
			     (plus 1 then-n
				   (lr-p-c-size t (caddr expr))))))))
	((equal (car expr) (s-temp-fetch)) t)
	((equal (car expr) (s-temp-eval))
	 (induct-hint-7 (cdr pos) (cadr expr) n))
	((equal (car expr) (s-temp-test))
	 (induct-hint-7 (cdr pos) (cadr expr) (plus n 4)))
	((equal (car expr) 'quote) t)
	(t (induct-hint-7 (cdr pos)
			  (get (car pos) expr)
			  (plus n
				(lr-p-c-size-list (sub1 (car pos))
						  expr))))))

(prove-lemma LR-P-C-SIZE-S-TEMP-TEST-EVAL-CADR-NOT-LESSP-FACT (rewrite)
  (implies (and (listp expr)
		(or (equal (car expr) (s-temp-eval))
		    (equal (car expr) (s-temp-test))))
	   (lessp (lr-p-c-size t (cadr expr)) (lr-p-c-size t expr)))
  ((expand (lr-p-c-size t expr))
   (disable-theory addition)
   (disable lr-p-c-size)))

(prove-lemma LENGTH-COMP-TEMP-TEST (rewrite)
  (implies (and (listp body)
		(equal (car body) (s-temp-test)))
	   (equal (length (comp-temp-test any-body
					  (comp-body-1 t (cadr body) n)
					  any-n))
		  (lr-p-c-size t body)))
  ((disable lr-p-c-size)
   (expand (lr-p-c-size t body))))

(prove-lemma PLISTP-COMP-TEMP-TEST (rewrite)
  (plistp (comp-temp-test body instrs n)))

(prove-lemma LENGTH-COMP-IF-ALT (rewrite)
  (implies (and (listp body)
		(equal (car body) 'if))
	   (equal (length (comp-if (comp-body-1 t (cadr body) n1)
				   (comp-body-1 t (caddr body) n2)
				   (comp-body-1 t (cadddr body) n3)
				   any-n))
		  (lr-p-c-size t body)))
  ((disable lr-p-c-size)
   (expand (lr-p-c-size t body))))

(prove-lemma PLISTP-COMP-IF (rewrite)
  (implies (and (plistp else-instrs)
		(listp else-instrs))
	   (plistp (comp-if test-intrs then-instrs else-instrs n))))

(prove-lemma PLISTP-COMP-BODY-1 (rewrite)
  (plistp (comp-body-1 flag body n))
  ((induct (comp-body-1 flag body n))
   (expand (comp-body-1 flag body n)
	   (comp-body-1 'list body n))
   (disable comp-if comp-temp-test)))

(prove-lemma LR-P-C-SIZE-LIST-FUNCALL-NOT-LESSP-FACT (rewrite)
  (implies (and (listp expr)
		(not (equal (car expr) (s-temp-fetch)))
		(not (equal (car expr) (s-temp-eval)))
		(not (equal (car expr) (s-temp-test)))
		(not (equal (car expr) 'quote))
		(not (equal (car expr) 'if)))
	   (lessp (lr-p-c-size-list (sub1 (length expr)) expr)
		  (lr-p-c-size t expr)))
  ((expand (lr-p-c-size t expr))
   (disable-theory addition)
   (disable lr-p-c-size)))

(prove-lemma LR-P-C-SIZE-NLISTP-BODY (rewrite)
  (implies (not (listp body))
	   (equal (lr-p-c-size t body) 1)))

(prove-lemma FIRSTN-LR-P-C-SIZE-RESTN-LR-P-PC-1-COMP-BODY-1-HELPER-1 (rewrite)
  (implies (and (good-posp1 pos (cadr body))
		(equal (car body) 'if)
		(listp body)
		(lr-proper-exprp t body pnames formals temps table))
	   (equal (firstn (lr-p-c-size t (cur-expr pos (cadr body)))
			  (restn (lr-p-pc-1 (cadr body) pos)
				 (comp-if (comp-body-1 t (cadr body) n)
					  then-instrs
					  else-instrs
					  n)))
		  (firstn (lr-p-c-size t (cur-expr pos (cadr body)))
			  (restn (lr-p-pc-1 (cadr body) pos)
				 (comp-body-1 t (cadr body) n)))))
  ((expand (lr-proper-exprp t body pnames formals temps table)
	   (lr-proper-exprp 'list (cdr body) pnames formals temps table))
   (disable-theory addition)
   (disable cur-expr firstn lr-proper-exprp lr-p-pc-1
	    lr-p-c-size restn)))

(prove-lemma FIRSTN-RESTN-PLUS-COMP-IF-1 (rewrite)
  (implies (and (equal j (length test))
		(listp then)
		(lessp m (length then))
		(numberp m)
		(listp test)
		(not (lessp (length then) (plus k m))))
	   (equal (firstn k
			  (restn (plus 3 j m)
				 (comp-if test then else n)))
		  (firstn k (restn m then))))
  ((enable restn-cdr)
   (disable firstn restn
	    firstn-with-large-index
	    restn-add1-opener
	    restn-with-large-index)))

(prove-lemma FIRSTN-UNLABEL-INSTRS-COMP-BODY-1-LR-P-PC-1-HELPER-2 (rewrite)
  (implies (and (good-posp1 pos (caddr body))
		(equal (car body) 'if)
		(listp body)
		(lr-proper-exprp t body pnames formals temps table))
	   (not (lessp (lr-p-c-size t (caddr body))
		       (plus (lr-p-pc-1 (caddr body) pos)
			     (lr-p-c-size t (cur-expr pos (caddr body)))))))
  ((expand (lr-proper-exprp t body pnames formals temps table)
	   (lr-proper-exprp 'list (cdr body) pnames formals temps table)
	   (lr-proper-exprp 'list (cddr body) pnames formals temps table))
   (disable-theory addition)
   (disable cur-expr lr-proper-exprp lr-p-c-size lr-p-pc-1)))

(prove-lemma FIRSTN-RESTN-PLUS-COMP-IF-2 (rewrite)
  (implies (and (equal j (length test))
		(equal i (length then))
		(listp then)
		(lessp m (length else))
		(numberp m)
		(listp test)
		(listp else)
		(not (lessp (length else) (plus m k))))
	   (equal (firstn k
			  (restn (plus j i m 4)
				 (comp-if test then else n)))
		  (firstn k (restn m else))))
  ((disable firstn restn
	    firstn-with-large-index
	    restn-add1-opener
	    restn-with-large-index)))

(prove-lemma FIRSTN-UNLABEL-INSTRS-COMP-BODY-1-LR-P-PC-1-HELPER-3 (rewrite)
  (implies (and (good-posp1 pos (cadddr body))
		(equal (car body) 'if)
		(listp body)
		(lr-proper-exprp t body pnames formals temps table))
	   (not (lessp (lr-p-c-size t (cadddr body))
		       (plus (lr-p-pc-1 (cadddr body) pos)
			     (lr-p-c-size t
					  (cur-expr pos (cadddr body)))))))
  ((expand (lr-proper-exprp t body pnames formals temps table)
	   (lr-proper-exprp 'list (cdr body) pnames formals temps table)
	   (lr-proper-exprp 'list (cddr body) pnames formals temps table)
	   (lr-proper-exprp 'list (cdddr body) pnames formals temps table))
   (disable-theory addition)
   (disable cur-expr lr-proper-exprp lr-p-c-size lr-p-pc-1)))

(prove-lemma PLUS-CONSTANT-FACT-HELPER-1 (rewrite)
  (equal (plus 1 n 3 x y) (plus n 4 x y)))

(prove-lemma FIRSTN-LR-P-C-SIZE-RESTN-LR-P-PC-1-COMP-BODY-1-HELPER-4 (rewrite)
  (implies (and (good-posp1 pos (cadr body))
		(listp body)
		(equal (car body) (s-temp-test))
		(lr-proper-exprp t body pnames formals temps table))
	   (equal (firstn (lr-p-c-size t (cur-expr pos (cadr body)))
			  (restn (plus (lr-p-pc-1 (cadr body) pos) 4)
				 (comp-temp-test body-1
						 (comp-body-1 t
							      (cadr body)
							      n)
						 m)))
		  (firstn (lr-p-c-size t (cur-expr pos (cadr body)))
			  (restn (lr-p-pc-1 (cadr body) pos)
				 (comp-body-1 t (cadr body) n)))))
  ((expand (lr-proper-exprp t body pnames formals temps table))
   (disable cur-expr firstn lr-proper-exprp
	    lr-p-c-size lr-p-pc-1 restn
	    firstn-with-large-index
	    lr-p-c-size-nlistp-body)))

(prove-lemma FIRSTN-LR-P-C-SIZE-RESTN-LR-P-PC-1-COMP-BODY-1-HELPER-5 (rewrite)
  (equal (plus 4 x) (plus x 4)))

(prove-lemma GOOD-POSP1-LR-PROPER-EXPRP-GET-CADDDR (rewrite)
  (implies (and (listp pos)
		(listp body)
		(equal (car body) 'if)
		(not (equal (car pos) 1))
		(not (equal (car pos) 2))
		(not (equal (car pos) 0))
		(numberp (car pos))
		(lr-proper-exprp t body pnames formals temps table)
		(lessp (sub1 (sub1 (sub1 (car pos))))
		       (length (cdddr body))))
	   (equal (get (car pos) body) (cadddr body)))
  ((enable lessp-4-not-zerop-not-1-not-2-3-get-car-pos)
   (expand (lr-proper-exprp t body pnames formals temps table))
   (disable lr-proper-exprp)))

(prove-lemma LR-PROPER-EXPRP-CADR-TEMPS (rewrite)
  (implies (and (lr-proper-exprp t expr pnames formals temps table)
		(or (equal (car expr) (s-temp-eval))
		    (equal (car expr) (s-temp-test))))
	   (lr-proper-exprp t (cadr expr) pnames formals temps table)))

(prove-lemma LESSP-PLUS-LR-P-C-SIZE-LR-P-PC-1-TEMPS (rewrite)
  (implies (and (good-posp1 pos (cadr body))
		(listp body)
		(or (equal (car body) (s-temp-eval))
		    (equal (car body) (s-temp-test)))
		(lr-proper-exprp t body pnames formals temps table))
	   (not (lessp (lr-p-c-size t (cadr body))
		       (plus (lr-p-pc-1 (cadr body) pos)
			     (lr-p-c-size t (cur-expr pos (cadr body)))))))
  ((expand (lr-proper-exprp t body pnames formals temps table))
   (disable lr-p-c-size lr-p-pc-1 lr-proper-exprp)))

(prove-lemma FIRSTN-LR-P-C-SIZE-RESTN-LR-P-PC-1-COMP-BODY-1-HELPER-6 (rewrite)
  (implies (and (listp body)
		(not (equal (car body) 'if))
		(not (equal (car body) (s-temp-fetch)))
		(not (equal (car body) (s-temp-eval)))
		(not (equal (car body) (s-temp-test)))
		(not (equal (car body) 'quote))
		(lr-proper-exprp t body pnames formals temps table)
		(not (zerop n)))
	   (not (lessp (lr-p-c-size-list (sub1 (length body)) body)
		       (plus (lr-p-c-size-list (sub1 n) body)
			     (lr-p-pc-1 (get n body) pos)))))
  ((enable get-large-index
	   lr-p-c-size-list-0)
   (expand (lr-proper-exprp t body pnames formals temps table)
	   (lr-p-c-size-list n body))
   (use (lessp-index-lessp-lr-p-c-size-list (body body) (n n)))
   (disable lr-p-c-size lr-p-c-size-list lr-p-pc-1 lr-proper-exprp
	    *1*p-runtime-support-programs
	    lessp-plus-lr-p-c-size-lr-p-pc-1-helper)))

(defn INDUCT-HINT-10 (n l x)
  (cond ((not (listp l)) t)
	((zerop n) t)
	((listp (cdr l))
	 (induct-hint-10 (sub1 n)
			 (cdr l)
			 (plus x (lr-p-c-size t (cadr l)))))
	(t t)))

(prove-lemma LR-P-C-SIZE-LIST-CAR-OPENER (rewrite)
  (implies (and (not (zerop n))
		(lessp n (length body)))
	   (equal (lr-p-c-size-list n body)
		  (plus (lr-p-c-size t (cadr body))
			(lr-p-c-size-list (sub1 n) (cdr body)))))
  ((enable lr-p-c-size-list-add1-opener)
   (induct (lr-p-c-size-list n body))
   (disable lr-p-c-size lr-p-c-size-list)))

(prove-lemma RESTN-COMP-BODY-1-LIST-FACT (rewrite)
  (implies (and (not (lessp (lr-p-c-size t (get m (cdr body))) j))
		(lessp m (length (cdr body)))
		(numberp m)
		(numberp n)
		(numberp j))
	   (equal (restn (plus (lr-p-c-size-list m body) j)
			 (comp-body-1 'list (cdr body) n))
		  (restn j
			 (comp-body-1 'list
				      (restn m (cdr body))
				      (plus n (lr-p-c-size-list m body))))))
  ((induct (induct-hint-10 m body n))
   (enable lr-p-c-size-list-0)
   (expand (get m (cdr body))
	   (comp-body-1 'list (cdr body) n))
   (disable lr-p-c-size lr-p-c-size-list)))

(disable lr-p-c-size-list-car-opener)

(prove-lemma FIRSTN-RESTN-SMALL-ENOUGH-CDR-COMP-BODY-1-LIST (rewrite)
  (implies (and (listp body)
		(not (lessp (lr-p-c-size t (car body)) (plus j k))))
	   (equal (firstn j (restn k (comp-body-1 'list body n)))
		  (firstn j (restn k (comp-body-1 t (car body) n)))))
  ((expand (comp-body-1 'list body n))
   (disable lr-p-c-size)))

(prove-lemma FIRSTN-LR-P-C-SIZE-RESTN-LR-P-PC-1-COMP-BODY-1-HELPER-7 (rewrite)
  (implies (and (listp body)
		(not (equal (car body) 'if))
		(not (equal (car body) (s-temp-fetch)))
		(not (equal (car body) (s-temp-eval)))
		(not (equal (car body) (s-temp-test)))
		(not (equal (car body) 'quote))
		(numberp n)
		(lr-proper-exprp t body pnames formals temps table)
		(not (zerop m))
		(lessp m (length body))
		(good-posp1 pos (get m body)))
	   (equal (firstn (lr-p-c-size t (cur-expr pos (get m body)))
			  (restn (plus (lr-p-c-size-list (sub1 m) body)
				       (lr-p-pc-1 (get m body) pos))
				 (comp-body-1 'list (cdr body) n)))
		  (firstn (lr-p-c-size t (cur-expr pos (get m body)))
			  (restn (lr-p-pc-1 (get m body) pos)
				 (comp-body-1 t
					      (get m body)
					      (plus n
						    (lr-p-c-size-list
						     (sub1 m)
						     body)))))))
  ((expand (lr-p-c-size-list m body)
	   (lr-p-c-size 'list (restn (sub1 m) (cdr body)))
	   (get m body)
	   (lr-proper-exprp t body pnames formals temps table))
   (use (lessp-index-lessp-lr-p-c-size-list (body body) (n m))
	(lr-proper-exprp-list-lr-proper-get-t
	 (expr (cdr body))
	 (n (sub1 m))
	 (temps temps) (formals formals) (pnames pnames) (table table)))
   (disable cur-expr firstn lr-proper-exprp
	    lr-p-c-size lr-p-c-size-list lr-p-pc-1 restn
	    *1*p-runtime-support-programs
	    firstn-with-large-index
	    lr-p-c-size-nlistp-body)))

(prove-lemma FIRSTN-LR-P-C-SIZE-RESTN-LR-P-PC-1-COMP-BODY-1-HELPER-8 (rewrite)
  (implies (and (listp body)
		(not (equal (car body) 'if))
		(not (equal (car body) (s-temp-fetch)))
		(not (equal (car body) (s-temp-eval)))
		(not (equal (car body) (s-temp-test)))
		(not (equal (car body) 'quote))
		(lr-proper-exprp t body pnames formals temps table)
		(not (zerop n))
		(lessp n (length body))
		(good-posp1 pos (get n body)))
	   (not (lessp (difference (lr-p-c-size-list (sub1 (length body))
						     body)
				   (plus (lr-p-c-size-list (sub1 n) body)
					 (lr-p-pc-1 (get n body) pos)))
		       (lr-p-c-size t (cur-expr pos (get n body))))))
  ((enable get-large-index
	   lr-p-c-size-list-0)
   (expand (lr-proper-exprp t body pnames formals temps table)
	   (lr-p-c-size-list n body))
   (use (lessp-index-lessp-lr-p-c-size-list (body body) (n n))
	(lessp-plus-lr-p-c-size-lr-p-pc-1
	 (pos pos) (body (get n body))
	 (pnames pnames) (formals formals) (temps temps)))
   (disable lr-p-c-size lr-p-c-size-list lr-p-pc-1 lr-proper-exprp
	    *1*p-runtime-support-programs
	    lessp-plus-lr-p-c-size-lr-p-pc-1-helper)))

(prove-lemma FIRSTN-LR-P-C-SIZE-RESTN-LR-P-PC-1-COMP-BODY-1 (rewrite)
  (implies (and (good-posp1 pos body)
		(lr-proper-exprp t body pnames formals temps table)
		(numberp n))
	   (equal (firstn (lr-p-c-size t (cur-expr pos body))
			  (restn (lr-p-pc-1 body pos)
				 (comp-body-1 t body n)))
		  (comp-body-1 t
			       (cur-expr pos body)
			       (plus n (lr-p-pc-1 body pos)))))
  ((expand (cur-expr pos body)
	   (good-posp1 pos body)
	   (lr-p-pc-1 body pos)
	   (comp-body-1 t body n))
   (induct (induct-hint-7 pos body n))
   (disable-theory addition)
   (enable associativity-of-plus
	   get-large-index
	   lessp-4-not-zerop-not-1-not-2-3-get-car-pos
	   plus-zero-arg2)
   (disable comp-if comp-temp-test cur-expr firstn lr-proper-exprp
	    lr-p-c-size lr-p-pc-1 plus restn
	    *1*p-runtime-support-programs
	    restn-add1-opener
	    restn-with-large-index)))

(disable firstn-lr-p-c-size-restn-lr-p-pc-1-comp-body-1-helper-5)

(prove-lemma NOT-LESSP-LR-P-C-SIZE-FLAG-T-1 (rewrite)
  (not (lessp (lr-p-c-size t body1) 1)))

(prove-lemma NOT-LESSP-X-X (rewrite)
  (equal (lessp x x) f))

(prove-lemma GET-PLUS (rewrite)
  (equal (get (plus x y) list) (get y (restn x list)))
  ((enable get
	   get-anything-nil)
   (disable append-firstn-restn)))

(disable get-plus)

(prove-lemma GET-FIRSTN-DIFFERENT-LISTS ()
  (implies (and (lessp k n)
		(equal (firstn n list1) (firstn n list2)))
	   (equal (get k list1) (get k list2)))
  ((enable get)
   (disable append-firstn-restn)))

(prove-lemma UNLABEL-LIST-LABEL (rewrite)
  (equal (unlabel (list 'dl lab comment instr)) instr)
  ((enable unlabel)))

(prove-lemma LEGAL-LABELP-LABEL-MAKE-LABEL (rewrite)
  (legal-labelp (list 'dl (lr-make-label n) comment instr))
  ((enable legal-labelp)))

(prove-lemma LR-MAKE-LABEL-NOT-NUMBERP (rewrite)
  (implies (not (numberp n))
	   (equal (lr-make-label n) (lr-make-label 0)))
  ((enable lr-make-label)))

(defn INDUCT-HINT-9 (m instrs n)
  (if (listp instrs)
      (induct-hint-9 (sub1 m) (cdr instrs) (add1 n))
      t))

(prove-lemma GET-LABEL-INSTRS (rewrite)
  (implies (lessp m (length instrs))
	   (equal (get m (label-instrs instrs n))
		  (list 'dl (lr-make-label (plus n m)) () (get m instrs))))
  ((enable get)
   (induct (induct-hint-9 m instrs n))))

(disable lr-make-label-not-numberp)

(prove-lemma GET-APPEND (rewrite)
  (equal (get n (append x y))
	 (if (lessp n (length x))
	     (get n x)
	     (get (difference n (length x)) y)))
  ((enable get)
   (disable commutativity-of-plus)))

(disable get-append)

(prove-lemma GET-LR-P-C-SIZE-LESSP-LR-P-C-SIZE-COMP-BODY-1 (rewrite)
  (implies (and (good-posp1 pos body)
		(lr-proper-exprp t body pnames formals temps table)
		(numberp n)
		(lessp m (lr-p-c-size t (cur-expr pos body))))
	   (equal (get (plus (lr-p-pc-1 body pos) m) (comp-body-1 t body n))
		  (get m (comp-body-1 t
				      (cur-expr pos body)
				      (plus n (lr-p-pc-1 body pos))))))
  ((enable get-plus)
   (use (get-firstn-different-lists
	 (k m)
	 (list1 (restn (lr-p-pc-1 body pos) (comp-body-1 t body n)))
	 (list2 (comp-body-1 t
			     (cur-expr pos body)
			     (plus n (lr-p-pc-1 body pos))))
	 (n (lr-p-c-size t (cur-expr pos body)))))
   (disable-theory addition)
   (disable cur-expr firstn lr-proper-exprp lr-p-c-size
	    lr-p-pc-1 plus restn
	    *1*p-runtime-support-programs)))

(prove-lemma GET-LR-P-PC-1-COMP-BODY-1-CUR-EXPR-COMP-BODY (rewrite)
  (implies (and (good-posp1 (offset (p-pc l)) (program-body prog))
		(listp (lr-expr l))
		(equal (car (lr-expr l)) 'quote)
		(lr-programs-properp l table)
		(equal prog (p-current-program l)))
	   (equal (get (lr-p-pc-1 (program-body prog) (offset (p-pc l)))
		       (comp-body (program-body prog)))
		  (list 'dl
			(lr-make-label (lr-p-pc-1 (program-body prog)
						  (offset (p-pc l))))
			()
			(list 'push-constant (cadr (lr-expr l))))))
  ((use (lr-programs-properp-1-lr-proper-exprp
	 (prog prog)
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))
	 (progs (p-prog-segment l))
	 (table table))
	(get-lr-p-c-size-lessp-lr-p-c-size-comp-body-1
	 (pos (offset (p-pc l)))
	 (body (program-body prog))
	 (m 0) (n 0)
	 (pnames (strip-logic-fnames (cdr (p-prog-segment l))))
	 (formals (formal-vars prog))
	 (temps (strip-cars (temp-var-dcls prog)))))
   (enable comp-body lr-expr unlabel
	   get-append)
   (expand (comp-body-1 t
			(cur-expr (offset (p-pc l))
				  (program-body (p-current-program l)))
			(lr-p-pc-1 (program-body (p-current-program l))
				   (offset (p-pc l)))))
   (disable cur-expr comp-if comp-temp-test
	    lr-p-c-size lr-p-pc-1 lr-proper-exprp
	    get-lr-p-c-size-lessp-lr-p-c-size-comp-body-1)))

(prove-lemma GET-LR-P-PC-1-COMP-BODY-1-QUOTE (rewrite)
  (implies (and (good-posp1 (offset (p-pc l))
			    (program-body (car (p-prog-segment l))))
		(listp (lr-expr l))
		(equal (car (lr-expr l)) 'quote)
		(lr-programs-properp l table)
		(equal (area-name (p-pc l)) (caar (p-prog-segment l))))
	   (equal (get (lr-p-pc-1 (program-body (car (p-prog-segment l)))
				  (offset (p-pc l)))
		       (comp-body-1 t
				    (program-body (car (p-prog-segment l)))
				    0))
		  (list 'push-constant (cadr (lr-expr l)))))
  ((use (lr-programs-properp-1-lr-proper-exprp
	 (prog (car (p-prog-segment l)))
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))
	 (progs (p-prog-segment l))
	 (table table))
	(get-lr-p-c-size-lessp-lr-p-c-size-comp-body-1
	 (pos (offset (p-pc l)))
	 (body (program-body (car (p-prog-segment l))))
	 (m 0) (n 0)
	 (pnames (strip-logic-fnames (cdr (p-prog-segment l))))
	 (formals (formal-vars (car (p-prog-segment l))))
	 (temps (strip-cars (temp-var-dcls (car (p-prog-segment l)))))
	 (table table)))
   (enable comp-body lr-expr p-current-program unlabel
	   get-append)
   (expand (comp-body-1 t
			(cur-expr (offset (p-pc l))
				  (program-body (car (p-prog-segment l))))
			(lr-p-pc-1 (program-body (car (p-prog-segment l)))
				   (offset (p-pc l)))))
   (disable cur-expr comp-if comp-temp-test
	    lr-p-c-size lr-p-pc-1 lr-proper-exprp
	    get-lr-p-c-size-lessp-lr-p-c-size-comp-body-1)))

(prove-lemma PROPER-P-TEMP-STKP-P-TEMP-STK-LR-PUSH-TSTK-QUOTE (rewrite)
  (implies (and (lr-programs-properp l table)
		(proper-p-prog-segmentp (comp-programs (p-prog-segment l))
					(lr->p l))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(listp (lr-expr l))
		(equal (car (lr-expr l)) 'quote)
		(proper-p-temp-stkp (p-temp-stk l) (lr->p l)))
	   (proper-p-temp-stkp
	    (p-temp-stk (lr-push-tstk l (cadr (lr-expr l))))
	    (lr->p l)))
  ((enable lr-p-pc lr-push-tstk name p-current-program type unlabel
	   get-append)
   (disable-theory addition)
   (use (proper-p-prog-segmentp-implies-proper-p-programp
	 (segment (comp-programs (p-prog-segment l)))
	 (p (lr->p l))
	 (prog (p-current-program (lr->p l))))
	(proper-labeled-p-instructionsp-implies-labelp-and-instructionp
	 (lst (program-body (assoc (area-name (p-pc l))
				   (comp-programs (p-prog-segment l)))))
	 (name (area-name (p-pc l)))
	 (p (lr->p l))
	 (x (dl (lr-make-label (offset (lr-p-pc l))) ()
		(list 'push-constant (cadr (lr-expr l))))))
	(lr-programs-properp-expr-quote-type-addr
	 (l l) (flag flag) (table table))
	(proper-labeled-p-instructionsp-find-labelp-non-litatom
	 (body (program-body (assoc (area-name (p-pc l))
				   (comp-programs (p-prog-segment l)))))
	 (name (area-name (p-pc l)))
	 (p (lr->p l))
	 (label (cadr (lr-expr l))))
	(member-get
	 (n (offset (lr-p-pc l)))
	 (lst (program-body (assoc (area-name (p-pc l))
				   (comp-programs (p-prog-segment l)))))))
   (expand (proper-p-temp-stkp (cons (cadr (lr-expr l)) (p-temp-stk l))
			       (lr->p l)))
   (disable all-litatoms fall-off-proofp label-instrs lr-p-pc-1 lr-p-c-size
	    member-get
	    proper-labeled-p-instructionsp proper-p-prog-segmentp
	    proper-p-temp-var-dclsp proper-p-temp-stkp)))

(prove-lemma PROPER-P-STATEP-LR-PUSH-TSTK-QUOTE (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(listp (lr-expr l))
		(equal (car (lr-expr l)) 'quote)
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-push-tstk l (cadr (lr-expr l)))) 'run))
	   (proper-p-statep (lr->p (lr-push-tstk l (cadr (lr-expr l))))))
  ((enable proper-p-statep)
   (disable exp proper-p-alistp proper-p-ctrl-stkp proper-p-data-segmentp
	    proper-p-prog-segmentp)))

(prove-lemma GOOD-POSP-DV-1-FUNCALL-LR-EXPR (rewrite)
  (implies (and (listp (lr-expr l))
		(not (equal (car (lr-expr l)) 'if))
		(not (equal (car (lr-expr l)) (s-temp-eval)))
		(not (equal (car (lr-expr l)) (s-temp-test)))
		(not (equal (car (lr-expr l)) (s-temp-fetch)))
		(not (equal (car (lr-expr l)) 'quote))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l))))
	   (good-posp 'list
		      (dv (offset (p-pc l)) 1)
		      (program-body (p-current-program l))))
  ((enable dv lr-expr good-posp good-posp1
	   listp-not-lessp-length-1)
   (expand (cur-expr (offset (p-pc l)) (program-body (p-current-program l)))
	   (cur-expr nil (program-body (p-current-program l))))
   (disable cur-expr)))

(prove-lemma PLISTP-PAIRLIST (rewrite)
  (plistp (pairlist x y)))

(prove-lemma ALL-P-OBJECTPS-APPEND (rewrite)
  (implies (plistp lst1)
	   (equal (all-p-objectps (append lst1 lst2) p)
		  (and (all-p-objectps lst1 p)
		       (all-p-objectps lst2 p)))))

(prove-lemma ALL-P-OBJECTPS-REVERSE (rewrite)
  (implies (plistp lst)
	   (equal (all-p-objectps (reverse lst) p) (all-p-objectps lst p))))

(prove-lemma PLISTP-FIRST-N (rewrite)
  (plistp (first-n n list)))

(prove-lemma PROPER-P-TEMP-STKP-ALL-P-OBJECTPS (rewrite)
  (implies (proper-p-temp-stkp temp-stk p)
	   (all-p-objectps temp-stk p)))

(prove-lemma ALL-P-OBJECTPS-FIRST-N (rewrite)
  (implies (and (not (lessp (length lst) n))
		(all-p-objectps lst p))
	   (all-p-objectps (first-n n lst) p)))

(prove-lemma STRIP-CARS-APPEND (rewrite)
  (equal (strip-cars (append x y)) (append (strip-cars x) (strip-cars y))))

(disable strip-cars-append)

(prove-lemma STRIP-CARS-PAIRLIST (rewrite)
  (equal (strip-cars (pairlist x y)) (plist x)))

(disable strip-cars-pairlist)

(prove-lemma STRIP-CARS-PAIR-TEMPS-WITH-INITIAL-VALUES (rewrite)
  (equal (strip-cars (pair-temps-with-initial-values temp-var-decls))
	 (strip-cars temp-var-decls)))

(prove-lemma LENGTH-POPN (rewrite)
  (implies (not (lessp (length list) n))
	   (equal (length (popn n list)) (difference (length list) n))))

(prove-lemma PROPER-P-TEMP-STKP-POPN (rewrite)
  (implies (and (not (lessp (length temp-stk) n))
		(proper-p-temp-stkp temp-stk p))
	   (proper-p-temp-stkp (popn n temp-stk) p))
  ((induct (popn n temp-stk))))

(prove-lemma PROPER-P-PROG-SEGMENTP-LENGTH-PROGRAM-BODY (rewrite)
  (implies (and (proper-p-prog-segmentp prog-segment p)
		(definedp name prog-segment))
	   (listp (program-body (assoc name prog-segment))))
  ((enable proper-p-programp proper-p-program-bodyp)))

(prove-lemma RET-PC-MAKE-P-CALL-FRAME (rewrite)
  (equal (ret-pc (make-p-call-frame f-vars temp-stk temp-var-dcls ret-pc))
	 ret-pc))

(prove-lemma BINDINGS-MAKE-P-CALL-FRAME (rewrite)
  (equal (bindings (make-p-call-frame f-vars temp-stk temp-var-dcls ret-pc))
	 (append (pair-formal-vars-with-actuals f-vars temp-stk)
		 (pair-temps-with-initial-values temp-var-dcls))))

(prove-lemma CDDR-NIL-MAKE-P-CALL-FRAME (rewrite)
  (equal (cddr (make-p-call-frame f-vars temp-stk temp-var-dcls ret-pc))
	 nil))

(prove-lemma LISTP-CDR-MAKE-P-CALL-FRAME (rewrite)
  (listp (cdr (make-p-call-frame f-vars temp-stk temp-var-dcls ret-pc))))

(prove-lemma LENGTH-PAIRLIST (rewrite)
  (equal (length (pairlist x y)) (length x)))

(prove-lemma LENGTH-PAIR-TEMPS-WITH-INITIAL-VALUES (rewrite)
  (equal (length (pair-temps-with-initial-values temp-var-dcls))
	 (length temp-var-dcls)))

(prove-lemma NOT-PROPER-P-STATEP-NOT-LISTP-P-CTRL-STK (rewrite)
  (implies (not (listp (p-ctrl-stk l)))
	   (not (proper-p-statep (lr->p l))))
  ((enable proper-p-statep)
   (disable exp proper-p-alistp proper-p-ctrl-stkp proper-p-data-segmentp
	    proper-p-prog-segmentp)))

(prove-lemma PROPER-P-STATEP-BAD-TYPE-1 (rewrite)
  (implies (and (not (equal (fetch (car (p-temp-stk l)) (p-data-segment l))
			    (list (type (fetch (car (p-temp-stk l))
					       (p-data-segment l)))
				  (untag (fetch (car (p-temp-stk l))
						(p-data-segment l))))))
		(adpp (untag (car (p-temp-stk l))) (p-data-segment l)))
	   (not (proper-p-statep (lr->p l))))
  ((enable proper-p-statep)
   (disable exp proper-p-data-segmentp proper-p-framep proper-p-ctrl-stkp
	    proper-p-prog-segmentp proper-p-temp-stkp)
   (use (proper-p-data-segmentp-bad-type (data-seg (p-data-segment l))
					 (p (lr->p l))
					 (addr (car (p-temp-stk l)))))))

(prove-lemma P-GOOD-RESULTP-RUN-CAR ()
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call car)))
	   (p-good-resultp (p (p-set-pc (lr->p l) pc)
			      (p-car-clock (p-set-pc (lr->p l) pc)))
			   (p-data-segment l)
			   (if (equal (fetch (top (p-temp-stk l))
					     (p-data-segment l))
				      (tag 'nat (lr-cons-tag)))
			       (cons (fetch (add-addr (top (p-temp-stk l))
						      (lr-car-offset))
					    (p-data-segment l))
				     (cdr (p-temp-stk l)))
			       (cons (lr-0-addr) (cdr (p-temp-stk l))))
			   (p-ctrl-stk l)
			   (add-addr pc 1)))
  ((enable p-car-clock p-set-pc
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   p-opener p-psw-p-halt-x-y-error-msg p-step1-opener)
   (disable-theory addition)
   (expand (first-n 1 (p-temp-stk l)) (popn 1 (p-temp-stk l)))
   (disable p-call-okp *1*x-y-error-msg)))

(prove-lemma P-GOOD-RESULTP-RUN-CDR ()
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call cdr)))
	   (p-good-resultp (p (p-set-pc (lr->p l) pc)
			      (p-cdr-clock (p-set-pc (lr->p l) pc)))
			   (p-data-segment l)
			   (if (equal (fetch (top (p-temp-stk l))
					     (p-data-segment l))
				      (tag 'nat (lr-cons-tag)))
			       (cons (fetch (add-addr (top (p-temp-stk l))
						      (lr-cdr-offset))
					    (p-data-segment l))
				     (cdr (p-temp-stk l)))
			       (cons (lr-0-addr) (cdr (p-temp-stk l))))
			   (p-ctrl-stk l)
			   (add-addr pc 1)))
  ((enable p-cdr-clock p-set-pc
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   p-opener p-psw-p-halt-x-y-error-msg p-step1-opener)
   (disable-theory addition)
   (expand (first-n 1 (p-temp-stk l)) (popn 1 (p-temp-stk l)))
   (disable p-call-okp *1*x-y-error-msg)))

(prove-lemma P-GOOD-RESULTP-RUN-LISTP ()
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call listp)))
	   (p-good-resultp (p (p-set-pc (lr->p l) pc)
			      (p-listp-clock (p-set-pc (lr->p l) pc)))
			   (p-data-segment l)
			   (if (equal (fetch (car (p-temp-stk l))
					     (p-data-segment l))
				      (tag 'nat (lr-cons-tag)))
			       (cons (lr-t-addr) (cdr (p-temp-stk l)))
			       (cons (lr-f-addr) (cdr (p-temp-stk l))))
			   (p-ctrl-stk l)
			   (add-addr pc 1)))
  ((enable p-listp-clock p-set-pc
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   p-opener p-psw-p-halt-x-y-error-msg
	   p-step1-opener)
   (disable p-call-okp *1*x-y-error-msg)
   (do-not-induct t)))

(prove-lemma P-GOOD-RESULTP-RUN-NLISTP ()
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call nlistp)))
	   (p-good-resultp (p (p-set-pc (lr->p l) pc)
			      (p-nlistp-clock (p-set-pc (lr->p l) pc)))
			   (p-data-segment l)
			   (if (equal (fetch (car (p-temp-stk l))
					     (p-data-segment l))
				      (tag 'nat (lr-cons-tag)))
			       (cons (lr-f-addr) (cdr (p-temp-stk l)))
			       (cons (lr-t-addr) (cdr (p-temp-stk l))))
			   (p-ctrl-stk l)
			   (add-addr pc 1)))
  ((enable p-nlistp-clock p-set-pc
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   p-opener p-psw-p-halt-x-y-error-msg
	   p-step1-opener)
   (disable p-call-okp *1*x-y-error-msg)
   (do-not-induct t)))

(prove-lemma P-GOOD-RESULTP-RUN-TRUEP ()
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call truep)))
	   (p-good-resultp (p (p-set-pc (lr->p l) pc)
			      (p-truep-clock (p-set-pc (lr->p l) pc)))
			   (p-data-segment l)
			   (if (equal (fetch (car (p-temp-stk l))
					     (p-data-segment l))
				      (tag 'nat (lr-true-tag)))
			       (cons (lr-t-addr) (cdr (p-temp-stk l)))
			       (cons (lr-f-addr) (cdr (p-temp-stk l))))
			   (p-ctrl-stk l)
			   (add-addr pc 1)))
  ((enable p-truep-clock p-set-pc
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   p-opener p-psw-p-halt-x-y-error-msg
	   p-step1-opener)
   (disable p-call-okp *1*x-y-error-msg)))

(disable proper-p-statep-bad-type-1)

(prove-lemma P-GOOD-RESULTP-RUN-CONS ()
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call cons)))
	   (p-good-resultp (p (p-set-pc (lr->p l) pc)
			      (p-cons-clock (p-set-pc (lr->p l) pc)))
			   (deposit
			    (fetch (add-addr (fetch (lr-fp-addr)
						    (p-data-segment l))
					     (lr-ref-count-offset))
				   (p-data-segment l))
			    (lr-fp-addr)
			    (deposit-a-list
			     (list (tag 'nat (lr-cons-tag))
				   (tag 'nat 1)
				   (top1 (p-temp-stk l))
				   (top (p-temp-stk l)))
			     (fetch (lr-fp-addr)
				    (p-data-segment l))
			     (p-data-segment l)))
			   (cons (fetch (lr-fp-addr) (p-data-segment l))
				 (cddr (p-temp-stk l)))
			   (p-ctrl-stk l)
			   (add-addr pc 1)))
  ((enable p-cons-clock p-set-pc
	   adpp-deposit-anything-at-all
	   adpp-untag-definedp-area-name
	   adpp-untag-numberp-offset
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   p-opener p-psw-p-halt-x-y-error-msg p-step1-opener)
   (disable p-call-okp *1*x-y-error-msg)
   (do-not-induct t)))

(prove-lemma P-OBJECTP-BAD-TYPE ()
  (implies (not (equal object (list (type object) (untag object))))
	   (not (p-objectp object p)))
  ((enable p-objectp type untag)
   (disable booleanp bit-vectorp pcpp small-integerp
	    small-naturalp *1*p-runtime-support-programs
	    p-objectp-opener)))

(prove-lemma PROPER-P-STATEP-BAD-TYPE-2 (rewrite)
  (implies (and (not (equal (car (p-temp-stk l))
			    (list (type (car (p-temp-stk l)))
				  (untag (car (p-temp-stk l))))))
		(listp (p-temp-stk l)))
	   (not (proper-p-statep (lr->p l))))
  ((enable proper-p-statep)
   (use (p-objectp-bad-type (object (car (p-temp-stk l))) (p (lr->p l))))
   (disable exp proper-p-data-segmentp proper-p-ctrl-stkp proper-p-framep
	    proper-p-prog-segmentp)))

(prove-lemma P-GOOD-RESULTP-RUN-FALSEP ()
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call falsep)))
	   (p-good-resultp (p (p-set-pc (lr->p l) pc)
			      (p-falsep-clock (p-set-pc (lr->p l) pc)))
			   (p-data-segment l)
			   (if (equal (car (p-temp-stk l)) (lr-f-addr))
			       (cons (lr-t-addr) (cdr (p-temp-stk l)))
			       (cons (lr-f-addr) (cdr (p-temp-stk l))))
			   (p-ctrl-stk l)
			   (add-addr pc 1)))
  ((enable p-falsep-clock p-set-pc
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   p-opener p-psw-p-halt-x-y-error-msg
	   p-step1-opener)
   (disable p-call-okp *1*x-y-error-msg)))

(disable proper-p-statep-bad-type-2)

(prove-lemma P-GOOD-RESULTP-RUN-FALSE ()
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call false)))
	   (p-good-resultp (p (p-set-pc (lr->p l) pc)
			      (p-false-clock (p-set-pc (lr->p l) pc)))
			   (p-data-segment l)
			   (cons (lr-f-addr) (p-temp-stk l))
			   (p-ctrl-stk l)
			   (add-addr pc 1)))
  ((enable p-false-clock p-set-pc
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   p-opener p-psw-p-halt-x-y-error-msg
	   p-step1-opener)
   (disable p-call-okp *1*x-y-error-msg)))

(prove-lemma P-GOOD-RESULTP-RUN-TRUE ()
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call true)))
	   (p-good-resultp (p (p-set-pc (lr->p l) pc)
			      (p-true-clock (p-set-pc (lr->p l) pc)))
			   (p-data-segment l)
			   (cons (lr-t-addr) (p-temp-stk l))
			   (p-ctrl-stk l)
			   (add-addr pc 1)))
  ((enable p-true-clock p-set-pc
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   p-opener p-psw-p-halt-x-y-error-msg
	   p-step1-opener)
   (disable p-call-okp *1*x-y-error-msg)))

(prove-lemma P-TEMP-STK-P-CTRL-STK-P-DATA-SEGMENT-RUN-CAR (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(equal (p-psw (p (p-set-pc (lr->p l) pc)
				 (p-car-clock (p-set-pc (lr->p l) pc))))
		       'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call car)))
	   (and (equal (p-temp-stk (p (p-set-pc (lr->p l) pc)
				      (p-car-clock (p-set-pc (lr->p l)
							     pc))))
		       (if (equal (fetch (top (p-temp-stk l))
					 (p-data-segment l))
				  (tag 'nat (lr-cons-tag)))
			   (cons (fetch (add-addr (top (p-temp-stk l))
						  (lr-car-offset))
					(p-data-segment l))
				 (cdr (p-temp-stk l)))
			   (cons (lr-0-addr)
				 (cdr (p-temp-stk l)))))
		(equal (p-ctrl-stk (p (p-set-pc (lr->p l) pc)
				      (p-car-clock (p-set-pc (lr->p l)
							     pc))))
		       (p-ctrl-stk l))
		(equal (p-data-segment (p (p-set-pc (lr->p l) pc)
					  (p-car-clock (p-set-pc (lr->p l)
								 pc))))
		       (p-data-segment l))))
  ((enable p-good-resultp)
   (use (p-good-resultp-run-car
	 (l l)
	 (return-pc return-pc)
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))))
   (disable-theory addition)))

(prove-lemma P-TEMP-STK-P-CTRL-STK-P-DATA-SEGMENT-RUN-CDR (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(equal (p-psw (p (p-set-pc (lr->p l) pc)
				 (p-cdr-clock (p-set-pc (lr->p l) pc))))
		       'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call cdr)))
	   (and (equal (p-temp-stk (p (p-set-pc (lr->p l) pc)
				      (p-cdr-clock (p-set-pc (lr->p l)
							     pc))))
		       (if (equal (fetch (top (p-temp-stk l))
					 (p-data-segment l))
				  (tag 'nat (lr-cons-tag)))
			   (cons (fetch (add-addr (top (p-temp-stk l))
						  (lr-cdr-offset))
					(p-data-segment l))
				 (cdr (p-temp-stk l)))
			   (cons (lr-0-addr)
				 (cdr (p-temp-stk l)))))
		(equal (p-ctrl-stk (p (p-set-pc (lr->p l) pc)
				      (p-cdr-clock (p-set-pc (lr->p l)
							     pc))))
		       (p-ctrl-stk l))
		(equal (p-data-segment (p (p-set-pc (lr->p l) pc)
					  (p-cdr-clock (p-set-pc (lr->p l)
								 pc))))
		       (p-data-segment l))))

  ((enable p-good-resultp)
   (use (p-good-resultp-run-cdr
	 (l l)
	 (return-pc return-pc)
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))))
   (disable-theory addition)))

(prove-lemma P-TEMP-STK-P-CTRL-STK-P-DATA-SEGMENT-RUN-CONS (rewrite)
  (let ((fp-addr (fetch (lr-fp-addr) (p-data-segment l))))
    (implies (and (proper-p-statep (lr->p l))
		  (equal (p-psw l) 'run)
		  (equal (p-psw (p (p-set-pc (lr->p l) pc)
				   (p-cons-clock (p-set-pc (lr->p l) pc))))
			 'run)
		  (lr-programs-properp l table)
		  (equal (unlabel
			  (get (offset pc)
			       (program-body
				(assoc (area-name pc)
				       (p-prog-segment (lr->p l))))))
			 '(call cons)))
	     (and (equal (p-temp-stk (p (p-set-pc (lr->p l) pc)
					(p-cons-clock (p-set-pc (lr->p l)
								pc))))
			 (cons (fetch (lr-fp-addr) (p-data-segment l))
			       (cddr (p-temp-stk l))))
		  (equal (p-ctrl-stk (p (p-set-pc (lr->p l) pc)
					(p-cons-clock (p-set-pc (lr->p l)
								pc))))
			 (p-ctrl-stk l))
		  (equal
		   (p-data-segment (p (p-set-pc (lr->p l) pc)
				      (p-cons-clock (p-set-pc (lr->p l)
							      pc))))
		   (deposit (fetch (add-addr (fetch (lr-fp-addr)
						    (p-data-segment l))
					     (lr-ref-count-offset))
				   (p-data-segment l))
			    (lr-fp-addr)
			    (deposit-a-list
			     (list (tag 'nat (lr-cons-tag))
				   (tag 'nat 1)
				   (top1 (p-temp-stk l))
				   (top (p-temp-stk l)))
			     (fetch (lr-fp-addr)
				    (p-data-segment l))
			     (p-data-segment l)))))))
  ((enable p-good-resultp)
   (use (p-good-resultp-run-cons
	 (l l)
	 (return-pc return-pc)
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))))
   (disable deposit-a-list-cons-opener)
   (disable-theory addition)))

(prove-lemma P-TEMP-STK-P-CTRL-STK-P-DATA-SEGMENT-RUN-FALSE (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(equal (p-psw (p (p-set-pc (lr->p l) pc)
				 (p-false-clock (p-set-pc (lr->p l) pc))))
		       'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call false)))
	   (and (equal (p-temp-stk (p (p-set-pc (lr->p l) pc)
				      (p-false-clock (p-set-pc (lr->p l)
							       pc))))
		       (cons (lr-f-addr) (p-temp-stk l)))
		(equal (p-ctrl-stk (p (p-set-pc (lr->p l) pc)
				      (p-false-clock (p-set-pc (lr->p l)
							       pc))))
		       (p-ctrl-stk l))
		(equal (p-data-segment (p (p-set-pc (lr->p l) pc)
					  (p-false-clock (p-set-pc (lr->p l)
								   pc))))
		       (p-data-segment l))))
  ((enable p-good-resultp)
   (use (p-good-resultp-run-false
	 (l l)
	 (return-pc return-pc)
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))))
   (disable-theory addition)))

(prove-lemma P-TEMP-STK-P-CTRL-STK-P-DATA-SEGMENT-RUN-FALSEP (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(equal (p-psw (p (p-set-pc (lr->p l) pc)
				 (p-falsep-clock (p-set-pc (lr->p l) pc))))
		       'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call falsep)))
	   (and (equal (p-temp-stk (p (p-set-pc (lr->p l) pc)
				      (p-falsep-clock (p-set-pc (lr->p l)
								pc))))
		       (if (equal (car (p-temp-stk l)) (lr-f-addr))
			   (cons (lr-t-addr) (cdr (p-temp-stk l)))
			   (cons (lr-f-addr) (cdr (p-temp-stk l)))))
		(equal (p-ctrl-stk (p (p-set-pc (lr->p l) pc)
				      (p-falsep-clock (p-set-pc (lr->p l)
								pc))))
		       (p-ctrl-stk l))
		(equal
		 (p-data-segment (p (p-set-pc (lr->p l) pc)
				    (p-falsep-clock (p-set-pc (lr->p l)
							      pc))))
		 (p-data-segment l))))
  ((enable p-good-resultp)
   (use (p-good-resultp-run-falsep
	 (l l)
	 (return-pc return-pc)
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))))
   (disable-theory addition)))

(prove-lemma P-TEMP-STK-P-CTRL-STK-P-DATA-SEGMENT-RUN-LISTP (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(equal (p-psw (p (p-set-pc (lr->p l) pc)
				 (p-listp-clock (p-set-pc (lr->p l) pc))))
		       'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call listp)))
	   (and (equal (p-temp-stk (p (p-set-pc (lr->p l) pc)
				      (p-listp-clock (p-set-pc (lr->p l)
							       pc))))
		       (if (equal (fetch (car (p-temp-stk l))
					 (p-data-segment l))
				  (tag 'nat (lr-cons-tag)))
			   (cons (lr-t-addr) (cdr (p-temp-stk l)))
			   (cons (lr-f-addr) (cdr (p-temp-stk l)))))
		(equal (p-ctrl-stk (p (p-set-pc (lr->p l) pc)
				      (p-listp-clock (p-set-pc (lr->p l)
							       pc))))
		       (p-ctrl-stk l))
		(equal (p-data-segment (p (p-set-pc (lr->p l) pc)
					  (p-listp-clock (p-set-pc (lr->p l)
								   pc))))
		       (p-data-segment l))))
  ((enable p-good-resultp)
   (use (p-good-resultp-run-listp
	 (l l)
	 (return-pc return-pc)
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))))
   (disable-theory addition)))

(prove-lemma P-TEMP-STK-P-CTRL-STK-P-DATA-SEGMENT-RUN-NLISTP (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(equal (p-psw (p (p-set-pc (lr->p l) pc)
				 (p-nlistp-clock (p-set-pc (lr->p l) pc))))
		       'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call nlistp)))
	   (and (equal (p-temp-stk (p (p-set-pc (lr->p l) pc)
				      (p-nlistp-clock (p-set-pc (lr->p l)
								pc))))
		       (if (equal (fetch (car (p-temp-stk l))
					 (p-data-segment l))
				  (tag 'nat (lr-cons-tag)))
			   (cons (lr-f-addr) (cdr (p-temp-stk l)))
			   (cons (lr-t-addr) (cdr (p-temp-stk l)))))
		(equal (p-ctrl-stk (p (p-set-pc (lr->p l) pc)
				      (p-nlistp-clock (p-set-pc (lr->p l)
								pc))))
		       (p-ctrl-stk l))
		(equal
		 (p-data-segment (p (p-set-pc (lr->p l) pc)
				    (p-nlistp-clock (p-set-pc (lr->p l)
							      pc))))
		 (p-data-segment l))))
  ((enable p-good-resultp)
   (use (p-good-resultp-run-nlistp
	 (l l)
	 (return-pc return-pc)
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))))
   (disable-theory addition)))

(prove-lemma P-TEMP-STK-P-CTRL-STK-P-DATA-SEGMENT-RUN-TRUE (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(equal (p-psw (p (p-set-pc (lr->p l) pc)
				 (p-true-clock (p-set-pc (lr->p l) pc))))
		       'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call true)))
	   (and (equal (p-temp-stk (p (p-set-pc (lr->p l) pc)
				      (p-true-clock (p-set-pc (lr->p l)
							      pc))))
		       (cons (lr-t-addr) (p-temp-stk l)))
		(equal (p-ctrl-stk (p (p-set-pc (lr->p l) pc)
				      (p-true-clock (p-set-pc (lr->p l)
							      pc))))
		       (p-ctrl-stk l))
		(equal (p-data-segment (p (p-set-pc (lr->p l) pc)
					  (p-true-clock (p-set-pc (lr->p l)
								  pc))))
		       (p-data-segment l))))
  ((enable p-good-resultp)
   (use (p-good-resultp-run-true
	 (l l)
	 (return-pc return-pc)
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))))
   (disable-theory addition)))

(prove-lemma P-TEMP-STK-P-CTRL-STK-P-DATA-SEGMENT-RUN-TRUEP (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(equal (p-psw l) 'run)
		(equal (p-psw (p (p-set-pc (lr->p l) pc)
				 (p-truep-clock (p-set-pc (lr->p l) pc))))
		       'run)
		(lr-programs-properp l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p l))))))
		       '(call truep)))
	   (and (equal (p-temp-stk (p (p-set-pc (lr->p l) pc)
				      (p-truep-clock (p-set-pc (lr->p l)
							       pc))))
		       (if (equal (fetch (car (p-temp-stk l))
					 (p-data-segment l))
				  (tag 'nat (lr-true-tag)))
			   (cons (lr-t-addr) (cdr (p-temp-stk l)))
			   (cons (lr-f-addr) (cdr (p-temp-stk l)))))
		(equal (p-ctrl-stk (p (p-set-pc (lr->p l) pc)
				      (p-truep-clock (p-set-pc (lr->p l)
							       pc))))
		       (p-ctrl-stk l))
		(equal (p-data-segment (p (p-set-pc (lr->p l) pc)
					  (p-truep-clock (p-set-pc (lr->p l)
								   pc))))
		       (p-data-segment l))))
  ((enable p-good-resultp)
   (use (p-good-resultp-run-truep
	 (l l)
	 (return-pc return-pc)
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))))
   (disable-theory addition)))

(prove-lemma GET-LAST-FUNCALL-CUR-EXPR (rewrite)
  (implies (and (listp expr)
		(not (equal (car expr) 'if))
		(not (equal (car expr) (s-temp-eval)))
		(not (equal (car expr) (s-temp-test)))
		(not (equal (car expr) (s-temp-fetch)))
		(not (equal (car expr) 'quote)))
	   (equal (get (lr-p-c-size-list (sub1 (length expr)) expr)
		       (comp-body-1 t expr n))
		  (if (definedp (car expr) (p-runtime-support-programs))
		      (list 'call (car expr))
		      (list 'call (user-fname (car expr))))))
  ((enable get-append)
   (expand (comp-body-1 t expr n))
   (disable lr-p-c-size lr-p-c-size-list
	    *1*p-runtime-support-programs)))

(prove-lemma NOT-LISTP-P-PROG-SEGMENT-LR-EXPR (rewrite)
  (implies (not (listp (p-prog-segment l)))
	   (not (listp (lr-expr l))))
  ((enable lr-expr p-current-program)))

(prove-lemma GET-OFFSET-RETURN-PC-PROGRAM-BODY-ASSOC-COMP-PROGRAMS (rewrite)
  (implies (and (good-posp1 (offset (p-pc l))
			    (program-body (assoc (area-name (p-pc l))
						 (p-prog-segment l))))
		(lr-programs-properp l table)
		(not (equal (car (lr-expr l)) 'if))
		(not (equal (car (lr-expr l)) (s-temp-eval)))
		(not (equal (car (lr-expr l)) (s-temp-test)))
		(not (equal (car (lr-expr l)) (s-temp-fetch)))
		(not (equal (car (lr-expr l)) 'quote))
		(listp (lr-expr l)))
	   (equal (get (offset (lr-return-pc l))
		       (program-body
			(assoc (area-name (p-pc l))
			       (comp-programs (p-prog-segment l)))))
		  (list 'dl
			(lr-make-label (offset (lr-return-pc l)))
			()
			(if (definedp (car (lr-expr l))
			      (p-runtime-support-programs))
			    (list 'call (car (lr-expr l)))
			    (list 'call (user-fname (car (lr-expr l))))))))
  ((enable comp-body lr-expr lr-programs-properp lr-return-pc lr-p-pc name
	   p-current-program
	   get-append)
   (use (lr-programs-properp-1-lr-proper-exprp
	 (prog (assoc (area-name (p-pc l)) (p-prog-segment l)))
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))
	 (progs (p-prog-segment l))
	 (table table))
	(lessp-plus-lr-p-c-size-lr-p-pc-1
	 (pos (offset (p-pc l))) (table table)
	 (body (program-body (assoc (area-name (p-pc l))
				    (p-prog-segment l))))
	 (pnames (strip-logic-fnames (cdr (p-prog-segment l))))
	 (formals (formal-vars (assoc (area-name (p-pc l))
				      (p-prog-segment l))))
	 (temps (strip-cars (temp-var-dcls (assoc (area-name (p-pc l))
						  (p-prog-segment l)))))))
   (expand
    (lr-p-c-size t
		 (cur-expr (offset (p-pc l))
			   (program-body (assoc (area-name (p-pc l))
						(p-prog-segment l))))))
   (disable cur-expr lr-proper-exprp lr-p-c-size lr-p-c-size-list lr-p-pc-1
	    *1*p-runtime-support-programs
	    lessp-plus-lr-p-c-size-lr-p-pc-1)))

(prove-lemma LISTP-P-TEMP-STK-PROPER-CTRL-STK-P-RUN-SUBR (rewrite)
  (implies (and (good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp new-l table)
		(lr-programs-properp l table)
		(listp (lr-expr l))
		(proper-p-statep (lr->p new-l))
		(equal (p-psw new-l) 'run)
		(equal (p-psw (p-run-subr (car (lr-expr l))
					  (p-set-pc (lr->p new-l)
						    (lr-return-pc l))))
		       'run)
		(equal (p-prog-segment l) (p-prog-segment new-l)))
	   (and
	    (listp (p-temp-stk (p-run-subr (car (lr-expr l))
					   (p-set-pc (lr->p new-l)
						     (lr-return-pc l)))))
	    (equal (p-ctrl-stk (p-run-subr (car (lr-expr l))
					   (p-set-pc (lr->p new-l)
						     (lr-return-pc l))))
		   (p-ctrl-stk new-l))))
  ((enable name p-run-subr p-current-program
	   get-append)
   (disable label-instrs length lr-p-c-size lr-p-c-size-list lr-p-pc-1
	    lr-proper-exprp
	    program-body-assoc-comp-programs)))

(prove-lemma LISTP-P-TEMP-STK-PROPER-CTRL-STK-LR-APPLY-SUBR (rewrite)
  (implies (and (good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(lr-programs-properp new-l table)
		(listp (lr-expr l))
		(subrp (car (lr-expr l)))
		(equal (p-psw (lr-apply-subr l new-l)) 'run)
		(proper-p-statep (lr->p new-l))
		(equal (p-psw new-l) 'run)
		(equal (p-prog-segment l) (p-prog-segment new-l)))
	   (and (listp (p-temp-stk (lr-apply-subr l new-l)))
		(equal (p-ctrl-stk (lr-apply-subr l new-l))
		       (p-ctrl-stk new-l))))
  ((enable lr-apply-subr)
   (disable definedp lr-p-c-size lr-p-c-size-list
	    *1*x-y-error-msg)))

(prove-lemma CUR-EXPR-NLISTP-POS (rewrite)
  (implies (nlistp pos)
	   (equal (cur-expr pos body) body)))

(prove-lemma PROPER-P-STATEP-P-RUN-SUBR (rewrite)
  (implies (and (proper-p-statep p)
		(equal (p-psw (p-run-subr subr p)) 'run))
	   (proper-p-statep (p-run-subr subr p)))
  ((enable p-run-subr)))

(prove-lemma SAME-SIGNATURE-COMMUTATIVE ()
  (equal (same-signature x y) (same-signature y x))
  ((enable same-signature)))

(prove-lemma SAME-SIGNATURE-P-RUN-SUBR (rewrite)
  (implies (and (proper-p-statep p)
		(equal (p-psw (p-run-subr subr p)) 'run)
		(equal data-seg (p-data-segment p)))
	   (same-signature data-seg (p-data-segment (p-run-subr subr p))))
  ((enable p-run-subr)
   (use (same-signature-commutative (x (p-data-segment (p-run-subr subr p)))
				    (y data-seg)))))

(prove-lemma PROPER-P-FRAMEP-LR->P-SIMILAR-STATES (rewrite)
  (implies (and (proper-p-framep frame name p0)
		(same-signature (p-data-segment p0) (p-data-segment p1))
		(equal (p-prog-segment p0) (p-prog-segment p1))
		(equal (p-word-size p0) (p-word-size p1)))
	   (proper-p-framep frame name p1)))

(prove-lemma CAR-UNTAG-P-PC-LR-EVAL (rewrite)
  (equal (car (untag (p-pc (lr-eval flag l c))))
	 (car (untag (p-pc l))))
  ((enable area-name)
   (use (area-name-p-pc-lr-eval (flag flag) (l l) (c c)))
   (disable area-name-p-pc-lr-eval)))

(prove-lemma LESSP-CDR-UNTAG-LR-RETURN-PC-LR-P-C-SIZE ()
  (implies (and (good-posp1 (offset (p-pc l))
			    (program-body (assoc (car (untag (p-pc l)))
						 (p-prog-segment l))))
		(lr-programs-properp l table)
		(or (subrp (car (lr-expr l)))
		    (litatom (car (lr-expr l))))
		(not (equal (car (lr-expr l)) 'if))
		(not (equal (car (lr-expr l)) 'quote))
		(equal name (area-name (p-pc l))))
	   (lessp (cdr (untag (lr-return-pc l)))
		  (length (program-body (assoc name
					       (comp-programs
						(p-prog-segment l)))))))
  ((enable add-addr area-name lr-expr lr-return-pc lr-p-pc
	   lr-programs-properp name p-current-program)
   (use (lr-programs-properp-1-lr-proper-exprp
	 (prog (assoc (car (untag (p-pc l))) (p-prog-segment l)))
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))
	 (progs (p-prog-segment l))
	 (table table))
	(lessp-plus-lr-p-c-size-lr-p-pc-1
	 (pos (offset (p-pc l))) (table table)
	 (body (program-body (assoc (car (untag (p-pc l)))
				    (p-prog-segment l))))
	 (pnames (strip-logic-fnames (cdr (p-prog-segment l))))
	 (formals (formal-vars (assoc (car (untag (p-pc l)))
				      (p-prog-segment l))))
	 (temps (strip-cars (temp-var-dcls (assoc (car (untag (p-pc l)))
						  (p-prog-segment l)))))))
   (expand (lr-p-c-size t
			(cur-expr (offset (p-pc l))
				  (program-body (car (p-prog-segment l)))))
	   (lr-p-c-size t
			(cur-expr (offset (p-pc l))
				  (program-body
				   (assoc (car (untag (p-pc l)))
					  (cdr (p-prog-segment l)))))))
   (disable lr-p-pc-1 lr-p-c-size lr-p-c-size-list lr-proper-exprp
	    lessp-plus-lr-p-c-size-lr-p-pc-1)))

(prove-lemma PROPER-P-STATEP-LR-APPLY-SUBR-STATE (rewrite)
  (implies (and (proper-p-statep (lr->p new-l))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(listp (lr-expr l))
		(subrp (car (lr-expr l)))
		(not (equal (car (lr-expr l)) 'if))
		(equal (p-prog-segment l) (p-prog-segment new-l))
		(equal (area-name (p-pc l)) (area-name (p-pc new-l))))
	     (proper-p-statep (p-set-pc (lr->p new-l) (lr-return-pc l))))
  ((enable area-name lr-expr lr-p-pc p-current-program proper-p-statep)
   (use (lessp-cdr-untag-lr-return-pc-lr-p-c-size
	 (flag flag)
	 (l l)
	 (name (car (untag (p-pc l))))
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))))
   (disable cur-expr definedp exp lr-p-c-size lr-p-c-size-list
	    lr-p-pc-1 lr-proper-exprp proper-p-ctrl-stkp
	    proper-p-data-segmentp proper-p-framep proper-p-prog-segmentp
	    lessp-cdr-untag-lr-return-pc-lr-p-c-size
	    program-body-assoc-comp-programs)))

(prove-lemma SAME-SIGNATURE-LR-APPLY-SUBR (rewrite)
  (implies (and (proper-p-statep (lr->p new-l))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(listp (lr-expr l))
		(subrp (car (lr-expr l)))
		(not (equal (car (lr-expr l)) 'if))
		(equal (p-prog-segment l) (p-prog-segment new-l))
		(equal (area-name (p-pc l)) (area-name (p-pc new-l)))
		(equal (p-psw (lr-apply-subr l new-l)) 'run)
		(equal data-seg (p-data-segment new-l)))
	   (same-signature data-seg
			   (p-data-segment (lr-apply-subr l new-l))))
  ((enable lr-apply-subr)))

(prove-lemma P-CURRENT-PROGRAM-LR-APPLY-SUBR (rewrite)
  (implies (and (equal (area-name (p-pc new-l)) (area-name (p-pc l)))
		(equal (p-prog-segment new-l) (p-prog-segment l)))
	   (equal (p-current-program (lr-apply-subr l new-l))
		  (p-current-program l)))
  ((enable p-current-program)))

(prove-lemma P-CURRENT-PROGRAM-LR-EVAL (rewrite)
  (equal (p-current-program (lr-eval flag l c)) (p-current-program l))
  ((enable p-current-program)))

(prove-lemma PROPER-P-FRAMEP-LR-APPLY-SUBR (rewrite)
  (implies (and (proper-p-statep (lr->p new-l))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(listp (lr-expr l))
		(subrp (car (lr-expr l)))
		(not (equal (car (lr-expr l)) 'if))
		(equal (p-prog-segment l) (p-prog-segment new-l))
		(equal (area-name (p-pc l)) (area-name (p-pc new-l)))
		(equal (p-psw (lr-apply-subr l new-l)) 'run)
		(equal name (area-name (p-pc new-l))))
	   (proper-p-framep (car (p-ctrl-stk new-l))
			    name
			    (lr->p (lr-apply-subr l new-l))))
  ((enable proper-p-statep)
   (use (proper-p-framep-lr->p-similar-states
	 (p0 (lr->p new-l))
	 (p1 (lr->p (lr-apply-subr l new-l)))
	 (name name)
	 (frame (car (p-ctrl-stk new-l)))))
   (disable proper-p-ctrl-stkp proper-p-data-segmentp proper-p-framep
	    proper-p-prog-segmentp
	    proper-p-framep-lr->p-similar-states)))

(prove-lemma PROPER-P-STATEP-LR->P-LESSP-CTRL-STK-SIZE (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(equal max (p-max-ctrl-stk-size l)))
	   (equal (lessp max (p-ctrl-stk-size (p-ctrl-stk l))) f))
  ((enable proper-p-statep)
   (disable proper-p-ctrl-stkp proper-p-data-segmentp proper-p-framep
	    proper-p-prog-segmentp)))

(disable proper-p-statep-lr->p-lessp-ctrl-stk-size)

(prove-lemma PROPER-P-STATEP-LR->P-NUMBERP-MAX-CTRL-STK-SIZE (rewrite)
  (implies (proper-p-statep (lr->p l))
	   (numberp (p-max-ctrl-stk-size l)))
  ((enable proper-p-statep)
   (disable proper-p-ctrl-stkp proper-p-data-segmentp proper-p-framep
	    proper-p-prog-segmentp)))

(disable proper-p-statep-lr->p-numberp-max-ctrl-stk-size)

(prove-lemma PROPER-P-STATEP-LR->P-NUMBERP-MAX-TEMP-STK-SIZE (rewrite)
  (implies (proper-p-statep (lr->p l))
	   (numberp (p-max-temp-stk-size l)))
  ((enable proper-p-statep)
   (disable proper-p-ctrl-stkp proper-p-data-segmentp proper-p-framep
	    proper-p-prog-segmentp)))

(disable proper-p-statep-lr->p-numberp-max-temp-stk-size)

(prove-lemma PROPER-P-STATEP-LR->P-NUMBERP-WORD-SIZE (rewrite)
  (implies (proper-p-statep (lr->p l))
	   (numberp (p-word-size l)))
  ((enable proper-p-statep)
   (disable proper-p-ctrl-stkp proper-p-data-segmentp proper-p-framep
	    proper-p-prog-segmentp)))

(disable proper-p-statep-lr->p-numberp-word-size)

(prove-lemma PROPER-P-STATEP-LR->P-LESSP-MAX-CTRL-STK-SIZE (rewrite)
  (implies (proper-p-statep (lr->p l))
	   (equal (lessp (p-max-ctrl-stk-size l) (exp 2 (p-word-size l)))
		  t))
  ((enable proper-p-statep)
   (disable exp proper-p-ctrl-stkp proper-p-data-segmentp proper-p-framep
	    proper-p-prog-segmentp)))

(disable proper-p-statep-lr->p-lessp-max-ctrl-stk-size)

(prove-lemma PROPER-P-STATEP-LR->P-LESSP-MAX-TEMP-STK-SIZE (rewrite)
  (implies (proper-p-statep (lr->p l))
	   (equal (lessp (p-max-temp-stk-size l) (exp 2 (p-word-size l)))
		  t))
  ((enable proper-p-statep)
   (disable exp proper-p-ctrl-stkp proper-p-data-segmentp proper-p-framep
	    proper-p-prog-segmentp)))

(disable proper-p-statep-lr->p-lessp-max-temp-stk-size)

(prove-lemma PROPER-P-STATEP-LR->P-EQUAL-WORD-SIZE-0 (rewrite)
  (implies (proper-p-statep (lr->p l))
	   (not (equal (p-word-size l) 0)))
  ((enable proper-p-statep)
   (disable exp proper-p-ctrl-stkp proper-p-data-segmentp proper-p-framep
	    proper-p-prog-segmentp)))

(disable proper-p-statep-lr->p-equal-word-size-0)

(prove-lemma PROPER-P-CTRL-STKP-LR-APPLY-SUBR (rewrite)
  (implies (and (proper-p-statep (lr->p new-l))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(listp (lr-expr l))
		(subrp (car (lr-expr l)))
		(not (equal (car (lr-expr l)) 'if))
		(equal (p-prog-segment l) (p-prog-segment new-l))
		(equal (area-name (p-pc l)) (area-name (p-pc new-l)))
		(equal (p-psw (lr-apply-subr l new-l)) 'run))
	   (proper-p-ctrl-stkp (cdr (p-ctrl-stk new-l))
			       (area-name (ret-pc (car (p-ctrl-stk new-l))))
			       (lr->p (lr-apply-subr l new-l))))
  ((enable proper-p-statep)
   (use (proper-p-ctrl-stkp-lr->p-similar-states
	 (p0 (lr->p new-l))
	 (p1 (lr->p (lr-apply-subr l new-l)))
	 (name (area-name (ret-pc (car (p-ctrl-stk new-l)))))
	 (ctrl-stk (cdr (p-ctrl-stk new-l)))))
   (disable proper-p-ctrl-stkp proper-p-data-segmentp proper-p-framep
	    proper-p-temp-stkp proper-p-prog-segmentp
	    proper-p-ctrl-stkp-lr->p-similar-states)))

(prove-lemma PROPER-P-PROG-SEGMENTP-LR-APPLY-SUBR (rewrite)
  (implies (and (proper-p-statep (lr->p new-l))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(listp (lr-expr l))
		(subrp (car (lr-expr l)))
		(not (equal (car (lr-expr l)) 'if))
		(equal (p-prog-segment l) (p-prog-segment new-l))
		(equal (area-name (p-pc l)) (area-name (p-pc new-l)))
		(equal (p-psw (lr-apply-subr l new-l)) 'run)
		(equal progs (p-prog-segment new-l)))
	   (proper-p-prog-segmentp (comp-programs progs)
				   (lr->p (lr-apply-subr l new-l))))
  ((enable proper-p-statep)
   (use (proper-p-prog-segmentp-lr->p-similar-states
	 (p0 (lr->p new-l))
	 (p1 (lr->p (lr-apply-subr l new-l)))
	 (programs (comp-programs progs))))
   (disable proper-p-ctrl-stkp proper-p-data-segmentp proper-p-framep
	    proper-p-temp-stkp proper-p-prog-segmentp
	    proper-p-prog-segmentp-lr->p-similar-states)))

(prove-lemma PROPER-P-STATE-P-P-RUN-SUBR-OPENER-1 ()
  (implies (and (proper-p-statep p)
		(equal (p-psw (p-run-subr subr p)) 'run))
	   (proper-p-temp-stkp (p-temp-stk (p-run-subr subr p))
			       (p-run-subr subr p)))
  ((use (proper-p-statep-p-run-subr (subr subr) (p p)))
   (enable proper-p-statep-restructuring)
   (disable proper-p-statep-p-run-subr)))

(prove-lemma PROPER-P-TEMP-STKP-LR-APPLY-SUBR (rewrite)
  (implies (and (proper-p-statep (lr->p new-l))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(listp (lr-expr l))
		(subrp (car (lr-expr l)))
		(not (equal (car (lr-expr l)) 'if))
		(equal (p-prog-segment l) (p-prog-segment new-l))
		(equal (area-name (p-pc l)) (area-name (p-pc new-l)))
		(equal (p-psw (lr-apply-subr l new-l)) 'run))
	   (proper-p-temp-stkp (p-temp-stk (lr-apply-subr l new-l))
			       (lr->p (lr-apply-subr l new-l))))
  ((enable lr-apply-subr)
   (use (proper-p-state-p-p-run-subr-opener-1
	 (subr (car (lr-expr l)))
	 (p (p-set-pc (lr->p new-l) (lr-return-pc l)))))
   (disable lr-p-c-size lr-p-c-size-list proper-p-temp-stkp
	    listp-p-temp-stk-proper-ctrl-stk-p-run-subr)))

(prove-lemma PROPER-P-STATE-P-P-RUN-SUBR-OPENER-2 ()
  (implies (and (proper-p-statep p)
		(equal (p-psw (p-run-subr subr p)) 'run))
	   (not (lessp (p-max-temp-stk-size p)
		       (length (p-temp-stk (p-run-subr subr p))))))
  ((use (proper-p-statep-p-run-subr (subr subr) (p p)))
   (enable proper-p-statep-restructuring)
   (disable proper-p-statep-p-run-subr)))

(prove-lemma NOT-LESSP-LENGTH-P-TEMP-STK-LR-APPLY-SUBR (rewrite)
  (implies (and (proper-p-statep (lr->p new-l))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(listp (lr-expr l))
		(subrp (car (lr-expr l)))
		(not (equal (car (lr-expr l)) 'if))
		(equal (p-prog-segment l) (p-prog-segment new-l))
		(equal (area-name (p-pc l)) (area-name (p-pc new-l)))
		(equal (p-psw (lr-apply-subr l new-l)) 'run)
		(equal (p-max-temp-stk-size l) (p-max-temp-stk-size new-l)))
	   (not (lessp (p-max-temp-stk-size l)
		       (length (p-temp-stk (lr-apply-subr l new-l))))))
  ((enable lr-apply-subr)
   (use (proper-p-state-p-p-run-subr-opener-2
	 (subr (car (lr-expr l)))
	 (p (p-set-pc (lr->p new-l) (lr-return-pc l)))))
   (disable lr-p-c-size lr-p-c-size-list
	    listp-p-temp-stk-proper-ctrl-stk-p-run-subr)))

(prove-lemma PROPER-P-STATE-P-P-RUN-SUBR-OPENER-3 ()
  (implies (and (proper-p-statep p)
		(equal (p-psw (p-run-subr subr p)) 'run))
	   (proper-p-data-segmentp (p-data-segment (p-run-subr subr p))
				   (p-run-subr subr p)))
  ((use (proper-p-statep-p-run-subr (subr subr) (p p)))
   (enable proper-p-statep-restructuring)
   (disable proper-p-statep-p-run-subr)))

(prove-lemma PROPER-P-DATA-SEGMENTP-LR-APPLY-SUBR (rewrite)
  (implies (and (proper-p-statep (lr->p new-l))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(listp (lr-expr l))
		(subrp (car (lr-expr l)))
		(not (equal (car (lr-expr l)) 'if))
		(equal (p-prog-segment l) (p-prog-segment new-l))
		(equal (area-name (p-pc l)) (area-name (p-pc new-l)))
		(equal (p-psw (lr-apply-subr l new-l)) 'run))
	   (proper-p-data-segmentp (p-data-segment (lr-apply-subr l new-l))
				   (lr->p (lr-apply-subr l new-l))))
  ((enable lr-apply-subr)
   (use (proper-p-state-p-p-run-subr-opener-3
	 (subr (car (lr-expr l)))
	 (p (p-set-pc (lr->p new-l) (lr-return-pc l)))))
   (disable lr-p-c-size lr-p-c-size-list proper-p-data-segmentp
	    listp-p-temp-stk-proper-ctrl-stk-p-run-subr)))

(prove-lemma LR-PROGRAMS-PROPERP-LR-SET-POS (rewrite)
  (equal (lr-programs-properp (lr-set-pos l pos) table)
	 (lr-programs-properp l table))
  ((enable lr-programs-properp)))

(prove-lemma PROPER-P-STATEP-LR-APPLY-SUBR (rewrite)
  (implies (and (listp (lr-expr l))
		(subrp (car (lr-expr l)))
		(not (equal (car (lr-expr l)) 'if))
		(proper-p-statep (lr->p l))
		(proper-p-statep (lr->p (lr-eval 'list
						 (lr-set-pos l pos)
						 c)))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval 'list (lr-set-pos l pos) c)) 'run)
		(equal (p-psw (lr-apply-subr l
					     (lr-eval 'list
						      (lr-set-pos l pos)
						      c)))
		       'run))
	   (proper-p-statep (lr->p (lr-apply-subr l
						  (lr-eval 'list
							   (lr-set-pos l
								       pos)
							   c)))))
  ((enable lr-p-pc name p-current-program
	   proper-p-statep-lr->p-lessp-ctrl-stk-size
	   proper-p-statep-lr->p-numberp-max-ctrl-stk-size
	   proper-p-statep-lr->p-numberp-max-temp-stk-size
	   proper-p-statep-lr->p-numberp-word-size
	   proper-p-statep-lr->p-lessp-max-ctrl-stk-size
	   proper-p-statep-lr->p-lessp-max-temp-stk-size
	   proper-p-statep-lr->p-equal-word-size-0)
   (use (same-signature-lr-apply-subr
	 (l l) (flag flag)
	 (new-l (lr-eval 'list (lr-set-pos l pos) c))
	 (data-seg (p-data-segment (lr-eval 'list (lr-set-pos l pos) c)))))
   (expand (proper-p-statep (lr->p (lr-apply-subr l
						  (lr-eval 'list
							   (lr-set-pos l
								       pos)
							   c)))))
   (disable definedp exp lr-eval lr-p-c-size lr-p-c-size-list lr-p-pc-1
	    proper-p-ctrl-stkp proper-p-data-segmentp proper-p-framep
	    proper-p-prog-segmentp
	    *1*x-y-error-msg
	    same-signature-lr-apply-subr)))

(prove-lemma CDR-UNTAG-LR-P-PC-LR-FUNCALL (rewrite)
  (implies (equal (p-psw (lr-funcall l new-l)) 'run)
	   (equal (cdr (untag (lr-p-pc (lr-funcall l new-l)))) 0))
  ((enable lr-funcall lr-p-pc)
   (disable p-call-okp make-p-call-frame)))

(prove-lemma LISTP-P-CTRL-STK-LR-FUNCALL (rewrite)
  (implies (listp (p-ctrl-stk new-l))
	   (listp (p-ctrl-stk (lr-funcall l new-l))))
  ((enable lr-funcall)
   (disable p-call-okp make-p-call-frame)))

(prove-lemma PROPER-P-FRAMEP-TOP-P-CTRL-STK-LR-FUNCALL (rewrite)
  (implies (equal (p-psw (lr-funcall l new-l)) 'run)
	   (and (listp (car (p-ctrl-stk (lr-funcall l new-l))))
		(listp (cdr (car (p-ctrl-stk (lr-funcall l new-l)))))
		(equal (cddr (car (p-ctrl-stk (lr-funcall l new-l)))) nil)
		(equal (ret-pc (car (p-ctrl-stk (lr-funcall l new-l))))
		       (add-addr (lr-return-pc l) 1))))
  ((enable lr-funcall)
   (disable p-call-okp make-p-call-frame)))

(prove-lemma CAR-UNTAG-P-PC-LR-FUNCALL (rewrite)
  (implies (equal (p-psw (lr-funcall l new-l)) 'run)
	   (equal (car (untag (p-pc (lr-funcall l new-l))))
		  (user-fname (car (lr-expr l)))))
  ((enable lr-funcall)
   (disable p-call-okp make-p-call-frame)))

(prove-lemma AREA-NAME-P-PC-LR-FUNCALL (rewrite)
  (implies (equal (p-psw (lr-funcall l new-l)) 'run)
	   (equal (area-name (p-pc (lr-funcall l new-l)))
		  (user-fname (car (lr-expr l)))))
  ((enable area-name)))

(prove-lemma STRIP-CARS-BINDINGS-TOP-P-CTRL-STK-LR-FUNCALL (rewrite)
  (implies (equal (p-psw (lr-funcall l new-l)) 'run)
	   (equal
	    (strip-cars (bindings (car (p-ctrl-stk (lr-funcall l new-l)))))
	    (append (formal-vars (assoc (user-fname (car (lr-expr l)))
					(p-prog-segment l)))
		    (strip-cars (temp-var-dcls
				 (assoc (user-fname (car (lr-expr l)))
					(p-prog-segment l)))))))
  ((enable lr-funcall
	   strip-cars-append
	   strip-cars-pairlist)
   (disable p-call-okp make-p-call-frame)))

(prove-lemma FORMAL-VARS-ASSOC-COMP-PROGRAMS-LR-PROGRAMS-PROPERP (rewrite)
  (implies (and (definedp name (cdr (p-prog-segment l)))
		(lr-programs-properp l table))
	   (equal (formal-vars (assoc name
				      (comp-programs (p-prog-segment l))))
		  (formal-vars (assoc name (p-prog-segment l))))))

(prove-lemma TEMP-VAR-DCLS-ASSOC-COMP-PROGRAMS-LR-PROGRAMS-PROPERP (rewrite)
  (implies (and (definedp name (cdr (p-prog-segment l)))
		(lr-programs-properp l table))
	   (equal (temp-var-dcls (assoc name
					(comp-programs (p-prog-segment l))))
		  (temp-var-dcls (assoc name (p-prog-segment l))))))

(prove-lemma DEFINEDP-COMP-PROGRAMS-DEFINEDP-LR-PROGRAMS-PROPERP (rewrite)
  (implies (and (definedp name (cdr (p-prog-segment l)))
		(lr-programs-properp l table))
	   (definedp name (comp-programs (p-prog-segment l)))))

(prove-lemma DEFINEDP-LR-FUNCALL-PROG-SEGMENT (rewrite)
  (implies (and (listp (lr-expr l))
		(not (subrp (car (lr-expr l))))
		(not (equal (car (lr-expr l)) 'quote))
		(litatom (car (lr-expr l)))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal progs (cdr (p-prog-segment l))))
	   (definedp (user-fname (car (lr-expr l))) progs))
  ((enable lr-programs-properp)
   (use (lr-programs-properp-lr-proper-exprp-lr-expr (l l) (table table)))))

(prove-lemma POP-P-CTRL-STK-LR-FUNCALL (rewrite)
  (implies (equal (p-psw (lr-funcall l new-l)) 'run)
	   (equal (cdr (p-ctrl-stk (lr-funcall l new-l)))
		  (p-ctrl-stk new-l)))
  ((enable lr-funcall)
   (disable p-call-okp make-p-call-frame)))

(prove-lemma PROPER-P-ALISTP-LR-FUNCALL (rewrite)
  (implies (and (lr-programs-properp l table)
		(definedp (user-fname (car (lr-expr l)))
			  (cdr (p-prog-segment new-l)))
		(proper-p-prog-segmentp
		 (comp-programs (p-prog-segment new-l))
		 (lr->p new-l))
		(proper-p-temp-stkp (p-temp-stk new-l) (lr->p new-l))
		(equal (p-psw (lr-funcall l new-l)) 'run)
		(equal (p-prog-segment l) (p-prog-segment new-l)))
	   (proper-p-alistp (bindings (car (p-ctrl-stk (lr-funcall l
								   new-l))))
			    (lr->p (lr-funcall l new-l))))
  ((enable lr-funcall)
   (use (all-litatoms-formal-vars-generalized
	 (segment (comp-programs (p-prog-segment new-l)))
	 (p (lr->p new-l))
	 (name (user-fname (car (lr-expr l)))))
	(proper-p-prog-segmentp-implies-proper-p-temp-var-dclsp
	 (segment (comp-programs (p-prog-segment new-l)))
	 (p (lr->p new-l))
	 (name (user-fname (car (lr-expr l))))))
   (disable make-p-call-frame p-ctrl-stk-size proper-p-alistp
	    proper-p-prog-segmentp proper-p-temp-stkp
	    definedp-comp-programs-definedp-orig
	    formal-vars-assoc-comp-programs
	    p-ins-okp-backchainer
	    proper-p-prog-segmentp-implies-proper-p-temp-var-dclsp
	    temp-var-dcls-assoc-comp-programs)))

(prove-lemma PROPER-P-CTRL-STKP-LR-FUNCALL (rewrite)
  (implies (and (proper-p-ctrl-stkp (cdr ctrl-stk)
				    (area-name (ret-pc (car ctrl-stk)))
				    (lr->p new-l))
		(proper-p-framep (top ctrl-stk) name (lr->p new-l))
		(listp ctrl-stk))
	   (proper-p-ctrl-stkp ctrl-stk
			       name
			       (lr->p (lr-funcall l new-l))))
  ((expand (proper-p-ctrl-stkp ctrl-stk
			       name
			       (lr->p (lr-funcall l new-l))))
   (disable proper-p-framep proper-p-ctrl-stkp)))

(prove-lemma NOT-LESSP-P-MAX-CTRL-STK-SIZE-LR-FUNCALL (rewrite)
  (implies (and (listp (lr-expr l))
		(not (subrp (car (lr-expr l))))
		(not (equal (car (lr-expr l)) 'quote))
		(litatom (car (lr-expr l)))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-funcall l new-l)) 'run)
		(equal (p-max-ctrl-stk-size l)
		       (p-max-ctrl-stk-size new-l))
		(equal (p-prog-segment l) (p-prog-segment new-l)))
	   (not (lessp (p-max-ctrl-stk-size l)
		       (p-ctrl-stk-size (p-ctrl-stk (lr-funcall l
								new-l))))))
  ((enable lr-funcall)
   (disable make-p-call-frame p-ctrl-stk-size
	    formal-vars-assoc-comp-programs
	    p-ins-okp-backchainer
	    temp-var-dcls-assoc-comp-programs)))

(prove-lemma OFFSET-P-PC-LR-FUNCALL (rewrite)
  (implies (equal (p-psw (lr-funcall l new-l)) 'run)
	   (equal (offset (p-pc (lr-funcall l new-l))) nil))
  ((enable lr-funcall)
   (disable make-p-call-frame p-call-okp p-ctrl-stk-size
	    p-ins-okp-backchainer)))

(prove-lemma LR-EVAL-T-LR-FUNCALL-P-PSW-RUN (rewrite)
  (implies (equal (p-psw (lr-eval t (lr-funcall l new-l) c)) 'run)
	   (equal (p-psw (lr-funcall l new-l)) 'run)))

(prove-lemma PROPER-P-TEMP-STKP-LR-FUNCALL (rewrite)
  (implies (and (listp (lr-expr l))
		(not (subrp (car (lr-expr l))))
		(not (equal (car (lr-expr l)) 'quote))
		(litatom (car (lr-expr l)))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-funcall l new-l)) 'run)
		(proper-p-temp-stkp (p-temp-stk new-l) (lr->p new-l))
		(equal (p-prog-segment l) (p-prog-segment new-l)))
	   (proper-p-temp-stkp (p-temp-stk (lr-funcall l new-l))
			       (lr->p (lr-funcall l new-l))))
  ((enable lr-funcall)
   (expand (definedp (car (lr-expr l)) (p-prog-segment l)))))

(prove-lemma POPN-NLISTP (rewrite)
  (implies (not (listp x))
	   (not (listp (popn n x)))))

(prove-lemma LENGTH-POPN-LESSP-FACT (rewrite)
  (not (lessp (length list) (length (popn n list)))))

(disable popn-nlistp)

(prove-lemma NOT-LESSP-P-MAX-TEMP-STK-SIZE-LR-FUNCALL (rewrite)
  (implies (and (not (lessp (p-max-temp-stk-size l)
			    (length (p-temp-stk new-l))))
		(equal (p-max-temp-stk-size l) (p-max-temp-stk-size new-l)))
	   (not (lessp (p-max-temp-stk-size l)
		       (length (p-temp-stk (lr-funcall l new-l))))))
  ((enable lr-funcall)
   (disable make-p-call-frame p-ctrl-stk-size
	    p-ins-okp-backchainer)))

(prove-lemma LISTP-LABEL-INSTRS (rewrite)
  (equal (listp (label-instrs list n)) (listp list)))

(prove-lemma LISTP-COMP-BODY (rewrite)
  (listp (comp-body body))
  ((enable comp-body)))

(prove-lemma LESSP-OFFSET-LR-RETURN-PC-LR-P-C-SIZE-GOOD-POSP (rewrite)
  (implies (and (good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(or (subrp (car (lr-expr l)))
		    (litatom (car (lr-expr l))))
		(not (equal (car (lr-expr l)) 'if))
		(not (equal (car (lr-expr l)) 'quote)))
	   (lessp (add1 (offset (lr-return-pc l)))
		  (length (program-body (assoc (area-name (p-pc l))
					       (comp-programs
						(p-prog-segment l)))))))
  ((enable lr-expr lr-p-pc lr-return-pc name p-current-program
	   lr-programs-properp)
   (use (lr-programs-properp-1-lr-proper-exprp
	 (prog (assoc (area-name (p-pc l)) (p-prog-segment l)))
	 (program-names (strip-logic-fnames (cdr (p-prog-segment l))))
	 (progs (p-prog-segment l))
	 (table table))
	(lessp-plus-lr-p-c-size-lr-p-pc-1
	 (pos (offset (p-pc l))) (table table)
	 (body (program-body (assoc (area-name (p-pc l))
				    (p-prog-segment l))))
	 (pnames (strip-logic-fnames (cdr (p-prog-segment l))))
	 (formals (formal-vars (assoc (area-name (p-pc l))
				      (p-prog-segment l))))
	 (temps (strip-cars (temp-var-dcls (assoc (area-name (p-pc l))
						  (p-prog-segment l)))))))
   (expand (lr-p-c-size t
			(cur-expr (offset (p-pc l))
				  (program-body
				   (assoc (area-name (p-pc l))
					  (cdr (p-prog-segment l))))))
	   (lr-p-c-size t
			(cur-expr (offset (p-pc l))
				  (program-body (car (p-prog-segment l))))))
   (disable cur-expr lr-p-pc-1 lr-proper-exprp lr-p-c-size lr-p-c-size-list
	    lessp-plus-lr-p-c-size-lr-p-pc-1)))

(prove-lemma PROPER-P-STATEP-LR-FUNCALL (rewrite)
  (implies (and (proper-p-statep (lr->p (lr-eval 'list
						 (lr-set-pos l pos)
						 c)))
		(listp (lr-expr l))
		(not (subrp (car (lr-expr l))))
		(not (equal (car (lr-expr l)) 'quote))
		(not (equal (car (lr-expr l)) 'if))
		(litatom (car (lr-expr l)))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval 'list (lr-set-pos l pos) c)) 'run)
		(equal (p-psw (lr-funcall l
					  (lr-eval 'list
						   (lr-set-pos l pos)
						   c)))
		       'run))
	   (proper-p-statep (lr->p (lr-funcall l
					       (lr-eval 'list
							(lr-set-pos l pos)
							c)))))
  ((enable proper-p-statep)
   (disable exp definedp p-ctrl-stk-size proper-p-alistp
	    proper-p-ctrl-stkp proper-p-data-segmentp proper-p-prog-segmentp
	    definedp-comp-programs-definedp-orig
	    program-body-assoc-comp-programs
	    formal-vars-assoc-comp-programs
	    temp-var-dcls-assoc-comp-programs)))

(prove-lemma PROPER-P-STATEP-LR-SET-EXPR-LR-POP-CSTK (rewrite)
  (let ((l2 (lr-eval t (lr-funcall l new-l) (sub1 c))))
    (implies (and (definedp (area-name (p-pc l)) (p-prog-segment l))
		  (equal (cdr (p-ctrl-stk l2)) (p-ctrl-stk new-l))
		  (equal (cdr (p-ctrl-stk new-l)) (cdr (p-ctrl-stk l)))
		  (equal (strip-cars (bindings (car (p-ctrl-stk new-l))))
			 (strip-cars (bindings (car (p-ctrl-stk l)))))
		  (proper-p-statep (lr->p l2))
		  (proper-p-statep (lr->p new-l))
		  (equal (p-psw l2) 'run)
		  (same-signature (p-data-segment new-l)
				  (p-data-segment l2))
		  (equal (p-prog-segment new-l) (p-prog-segment l))
		  (equal (area-name (p-pc new-l))(area-name (p-pc l)))
		  (equal pos (offset (p-pc l))))
	     (proper-p-statep (lr->p (lr-set-expr (lr-pop-cstk l2)
						  l
						  pos)))))
  ((enable lr-p-pc name p-current-program proper-p-statep)
   (expand (proper-p-ctrl-stkp (cdr (p-ctrl-stk l))
			       (area-name (ret-pc (car (p-ctrl-stk l))))
			       (lr->p l)))
   (disable exp definedp lr-eval lr-p-pc-1 p-ctrl-stk-size proper-p-alistp
	    proper-p-ctrl-stkp proper-p-data-segmentp proper-p-temp-stkp
	    proper-p-prog-segmentp)))

(prove-lemma P-PSW-LR-EVAL-FLAG-LIST-FLAG-T (rewrite)
  (implies (and (equal (p-psw (lr-eval 'list
				       (lr-set-expr (lr-eval t l c) l pos)
				       c))
		       'run)
		(listp (offset (p-pc l)))
		(listp (lr-expr-list l)))
	   (equal (p-psw (lr-eval t l c)) 'run))
  ((do-not-induct t)))

(prove-lemma LR-PROGRAMS-PROPERP-LR-SET-EXPR (rewrite)
  (equal (lr-programs-properp (lr-set-expr l1 l2 pos) table)
	 (lr-programs-properp l2 table))
  ((enable lr-programs-properp)))

(prove-lemma LR-PROGRAMS-PROPERP-LR-POP-TSTK (rewrite)
  (equal (lr-programs-properp (lr-pop-tstk l) table)
	 (lr-programs-properp l table))
  ((enable lr-programs-properp)))

(prove-lemma LR-PROGRAMS-PROPERP-LR-FUNCALL (rewrite)
  (implies (and (listp (lr-expr l))
		(not (subrp (car (lr-expr l))))
		(not (equal (car (lr-expr l)) 'quote))
		(litatom (car (lr-expr l)))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table))
	   (lr-programs-properp (lr-funcall l
					    (lr-eval 'list
						     (lr-set-pos l pos)
						     c))
				table))
  ((enable lr-funcall lr-programs-properp)
   (use (definedp-lr-funcall-prog-segment
	  (l l) (table table) (progs (cdr (p-prog-segment l)))))
   (disable lr-eval p-call-okp
	    definedp-lr-funcall-prog-segment)))

(prove-lemma PROPER-P-STATEP-LR->P-LR-SET-EXPR (rewrite)
  (implies (and (lr-programs-properp l2 table)
		(lr-programs-properp l1 table)
		(proper-p-statep (lr->p l2))
		(proper-p-statep (lr->p l1))
		(equal (cdr (p-ctrl-stk l1)) (cdr (p-ctrl-stk l2)))
		(equal (strip-cars (bindings (car (p-ctrl-stk l1))))
		       (strip-cars (bindings (car (p-ctrl-stk l2)))))
		(equal (p-prog-segment l1) (p-prog-segment l2))
		(equal (p-word-size l1) (p-word-size l2))
		(equal (p-max-ctrl-stk-size l1) (p-max-ctrl-stk-size l2))
		(equal (p-max-temp-stk-size l1) (p-max-temp-stk-size l2)))
	   (proper-p-statep (lr->p (lr-set-expr l1 l2 pos))))
  ((enable lr-p-pc name p-current-program p-invariant proper-p-statep)
   (disable lr-p-pc-1 proper-p-alistp proper-p-ctrl-stkp proper-p-temp-stkp
	    proper-p-prog-segmentp)))

(prove-lemma LR-PROGRAMS-PROPERP-LR-IF-OK (rewrite)
  (equal (lr-programs-properp (lr-if-ok l) table)
	 (lr-programs-properp l table))
  ((enable lr-programs-properp)))

(prove-lemma PROPER-P-STATEP-LR-IF-OK (rewrite)
  (equal (proper-p-statep (lr->p (lr-if-ok l)))
	 (proper-p-statep (lr->p l)))
  ((enable lr-p-pc proper-p-statep p-current-program)
   (disable exp lr-p-pc-1 proper-p-alistp proper-p-ctrl-stkp
	    proper-p-temp-stkp proper-p-data-segmentp
	    proper-p-prog-segmentp)))

(prove-lemma LR-EVAL-PRESERVES-PROPER-P-STATEP-LR->P ()
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag l c)) 'run))
	   (and (proper-p-statep (lr->p (lr-eval flag l c)))
		(equal (strip-cars (bindings (car (p-ctrl-stk
						   (lr-eval flag l c)))))
		       (strip-cars (bindings (car (p-ctrl-stk l)))))
		(equal (cdr (p-ctrl-stk (lr-eval flag l c)))
		       (cdr (p-ctrl-stk l)))
		(or (equal flag 'list)
		    (listp (p-temp-stk (lr-eval flag l c))))
		(same-signature (p-data-segment l)
				(p-data-segment (lr-eval flag l c)))))
  ((induct (lr-eval flag l c))
   (enable lr-eval-if-p-psw-1
	   transitivity-of-same-signature)
   (expand (lr-eval flag l c) (lr-eval 'list l c) (lr-eval flag l 0))
   (disable definedp lr-eval)
   (do-not-induct t)))

(prove-lemma LR-PARAMS-LR-EVAL (rewrite)
  (equal (lr-params frame (lr-eval flag l c)) (lr-params frame l))
  ((enable lr-params)))

(prove-lemma LR-TEMPS-LR-EVAL (rewrite)
  (equal (lr-temps frame (lr-eval flag l c)) (lr-temps frame l))
  ((enable lr-temps)))

;; Later LR-FREE-LIST-NODES will filter out those nodes that are
;; part of for example pack's or user-defined types that are larger than one
;; node (i.e. have more than two accessors).
(defn LR-FREE-LIST-NODES (addr data-seg)
  (if (lessp (offset addr) (lr-node-size))
      nil
      (let ((sub-addr (sub-addr addr (lr-node-size))))
	(if (equal (type (fetch (add-addr sub-addr (lr-ref-count-offset))
				data-seg))
		   'addr)
	    (cons sub-addr (lr-free-list-nodes sub-addr data-seg))
	    (lr-free-list-nodes sub-addr data-seg))))
  ((lessp (offset addr))))

(prove-lemma LENGTH-DELETE-MEMBER (rewrite)
  (implies (member addr node-list)
	   (equal (length (delete addr node-list))
		  (sub1 (length node-list)))))

;; Returns smallest address such that the address is too large to be
;; a pointer to a node in DATA-SEG.
(defn LR-MAX-NODE (data-seg)
  (tag 'addr
       (cons (lr-heap-name)
	     (sub1 (length (value (lr-heap-name) data-seg))))))

(defn LR-CHECK-FREE-NODES (addr node-list data-seg max-addr)
  (if (member addr node-list)
      (lr-check-free-nodes (fetch (add-addr addr
					    (lr-ref-count-offset))
				  data-seg)
			   (delete addr node-list)
			   data-seg
			   max-addr)
      (equal addr max-addr))
  ((lessp (length node-list))))

(defn LR-PROPER-FREE-LISTP (data-seg)
  (and (adpp (untag (lr-fp-addr)) data-seg)
       (lr-check-free-nodes (lr-fetch-fp data-seg)
			    (lr-free-list-nodes (lr-max-node data-seg)
						data-seg)
			    data-seg
			    (lr-max-node data-seg))))

(disable lr-proper-free-listp)

(defn LR-CHECK-F-ADDRP (addr data-seg)
  (equal addr (lr-f-addr)))

(disable lr-check-f-addrp)

(defn LR-CHECK-UNDEF-ADDRP (addr data-seg)
  (equal addr (lr-undef-addr)))

(disable lr-check-undef-addrp)

(defn LR-CHECK-NUMBERP-ADDRP (addr data-seg)
  (and (equal (type (fetch (add-addr addr
				     (lr-unbox-nat-offset))
			   data-seg))
	      'nat)
       ;; ***** The 3 below needs to be replaced by a constant *****
       (lr-good-pointerp (fetch (add-addr addr 3) data-seg) data-seg)
       (numberp (untag (fetch (add-addr addr (lr-unbox-nat-offset))
			      data-seg)))))

(disable lr-check-numberp-addrp)

(defn LR-CHECK-LISTP-ADDRP (addr data-seg)
  (and (lr-good-pointerp (fetch (add-addr addr (lr-car-offset)) data-seg)
			 data-seg)
       (lr-good-pointerp (fetch (add-addr addr (lr-cdr-offset)) data-seg)
			 data-seg)))

(disable lr-check-listp-addrp)

(defn LR-PROPER-HEAPP-NODEP (addr data-seg)
  (cond ((not (lr-nodep addr data-seg)) f)
	((equal (type (fetch (add-addr addr (lr-ref-count-offset))
			     data-seg))
		'addr)
	 (not (lessp (offset addr) (plus (lr-node-size)
					 (offset (lr-f-addr))))))
	((not (equal (type (fetch (add-addr addr (lr-ref-count-offset))
				  data-seg))
		     'nat))
	 f)
	((not (equal (type (fetch addr data-seg)) 'nat)) f)
	((equal (untag (fetch addr data-seg)) (lr-undefined-tag))
	 (lr-check-undef-addrp addr data-seg))
	((equal (untag (fetch addr data-seg)) (lr-false-tag))
	 (lr-check-f-addrp addr data-seg))
	((lessp (offset addr) (offset (lr-t-addr))) f)
	((equal (untag (fetch addr data-seg)) (lr-true-tag)) t)
	((equal (untag (fetch addr data-seg)) (lr-add1-tag))
	 (lr-check-numberp-addrp addr data-seg))
	((equal (untag (fetch addr data-seg)) (lr-cons-tag))
	 (lr-check-listp-addrp addr data-seg))
	(t f)))

(disable lr-proper-heapp-nodep)

(defn LR-PROPER-HEAPP2 (addr data-seg)
  (if (lessp (offset addr) (lr-node-size))
      t
      (let ((sub-addr (sub-addr addr (lr-node-size))))
	(and (lr-proper-heapp-nodep sub-addr data-seg)
	     (lr-proper-heapp2 sub-addr data-seg))))
  ((lessp (offset addr))))

(defn LR-VALP (value addr data-seg)
  (if (lr-good-pointerp addr data-seg)
      (let ((tag (untag (fetch addr data-seg))))
	(cond ((listp value)
	       (and (equal tag (lr-cons-tag))
		    (lr-valp (car value)
			     (fetch (add-addr addr (lr-car-offset))
				    data-seg)
			     data-seg)
		    (lr-valp (cdr value)
			     (fetch (add-addr addr (lr-cdr-offset))
				    data-seg)
			     data-seg)))
	      ((truep value) (equal tag (lr-true-tag)))
	      ((falsep value) (equal tag (lr-false-tag)))
	      ((numberp value)
	       ;; We could (and probably should) handle bignums here, but
	       ;; we don't.
	       (and (equal tag (lr-add1-tag))
		    (equal value
			   (untag (fetch (add-addr addr
						   (lr-unbox-nat-offset))
					 data-seg)))))
	      (t f)))
      f))

(defn LR-PROPER-HEAPP1 (addr data-seg)
  (and (lr-proper-heapp2 addr data-seg)
       (lr-valp t (lr-t-addr) data-seg)
       (lr-valp 0 (lr-0-addr) data-seg)))

(disable lr-proper-heapp1)

;; This is the minimum heap that allows all the predefineds to be defined.
(defn LR-MINIMUM-HEAPP (data-seg)
  (and (adpp (untag (lr-undef-addr)) data-seg)
       (adpp (untag (lr-f-addr)) data-seg)
       (adpp (untag (lr-t-addr)) data-seg)
       (adpp (untag (lr-0-addr)) data-seg)
       (adpp (untag (add-addr (lr-0-addr) (lr-node-size))) data-seg)))

(disable lr-minimum-heapp)

;; This needs to be augmented to test that the word-size is big enough to
;; hold piton tags.
(defn LR-PROPER-HEAPP (data-seg)
  (and (lr-minimum-heapp data-seg)
       (lr-nodep (lr-max-node data-seg) data-seg)
       (lr-proper-free-listp data-seg)
       (lr-proper-heapp1 (lr-max-node data-seg) data-seg)))

(disable lr-proper-heapp)

(defn LR-CHECK-RESULT1 (value temp-stk data-seg)
  (if (listp value)
      (and (lr-valp (car value) (top temp-stk) data-seg)
	   (lr-check-result1 (cdr value) (pop temp-stk) data-seg))
      t))

(defn LR-CHECK-RESULT (flag value temp-stk data-seg orig-temp-stk)
  (and (equal orig-temp-stk
	      (if (equal flag 'list)
		  (restn (length value) temp-stk)
		  (cdr temp-stk)))
       (if (equal flag 'list)
	   (lr-check-result1 (reverse value) temp-stk data-seg)
	   (lr-valp value (top temp-stk) data-seg))
       (lr-proper-heapp data-seg)))

(disable lr-check-result)

(defn LR-S-SIMILAR-PARAMS (s-params lr-params data-seg)
  (if (listp s-params)
      (if (listp lr-params)
	  (and (equal (caar s-params) (caar lr-params))
	       (lr-valp (cdar s-params) (cdar lr-params) data-seg)
	       (lr-s-similar-params (cdr s-params)
				    (cdr lr-params)
				    data-seg))
	  f)
      (nlistp lr-params)))

(defn LR-S-SIMILAR-TEMPS (s-temps lr-temps data-seg)
  (if (listp s-temps)
      (if (listp lr-temps)
	  (and (if (equal (cdar lr-temps) (lr-undef-addr))
		   (not (cadar s-temps))
		   (and (cadar s-temps)
			(lr-valp (caddar s-temps)
				 (cdar lr-temps)
				 data-seg)))
	       (lr-s-similar-temps (cdr s-temps) (cdr lr-temps) data-seg))
	  f)
      (nlistp lr-temps)))

(defn LR-S-SIMILAR-CONST-TABLE (table data-seg)
  (if (listp table)
      (and (lr-valp (caar table) (cdar table) data-seg)
	   (lr-s-similar-const-table (cdr table) data-seg))
      t))

(defn LR-S-SIMILAR-STATESP (s-params s-temps l table)
  (and (lr-s-similar-params s-params
			    (lr-params (top (p-ctrl-stk l)) l)
			    (p-data-segment l))
       (lr-s-similar-temps s-temps
			   (lr-temps (top (p-ctrl-stk l)) l)
			   (p-data-segment l))
       (lr-s-similar-const-table table (p-data-segment l))))

(disable lr-s-similar-statesp)

(prove-lemma P-ACCESSORS-S->LR1 (rewrite)
  (and (equal (p-pc (s->lr1 s l table))
	      (tag 'pc (cons (s-pname s) (s-pos s))))
       (equal (p-ctrl-stk (s->lr1 s l table)) (p-ctrl-stk l))
       (equal (p-temp-stk (s->lr1 s l table)) (p-temp-stk l))
       (equal (p-prog-segment (s->lr1 s l table))
	      (lr-compile-programs (s-progs s) table))
       (equal (p-data-segment (s->lr1 s l table)) (p-data-segment l))
       (equal (p-max-ctrl-stk-size (s->lr1 s l table))
	      (p-max-ctrl-stk-size l))
       (equal (p-max-temp-stk-size (s->lr1 s l table))
	      (p-max-temp-stk-size l))
       (equal (p-word-size (s->lr1 s l table)) (p-word-size l))
       (equal (p-psw (s->lr1 s l table)) (s-err-flag s)))
  ((enable s->lr1)))

(prove-lemma S-EVAL-ERR-FLAG-NOT-RUN-FACT (rewrite)
  (implies (not (equal (s-err-flag s) 'run))
	   (equal (s-eval flag s clock) s))
  ((enable s-eval)))

;; OFFSET
(prove-lemma OFFSET-TAG-CONS (rewrite)
  (equal (offset (tag tag (cons area offset))) offset)
  ((enable offset tag untag)))


;; ADP-NAME
(prove-lemma ADP-NAME-CONS (rewrite)
  (equal (adp-name (cons x y)) x))

;; OFFSET-SUB-ADDR -- see above


;; LR-PROPER-P-AREASP
(prove-lemma DEFINEDP-LITATOM-LR-PROPER-P-AREAS (rewrite)
  (implies (and (not (litatom name))
		(lr-proper-p-areasp data-seg))
	   (not (definedp name data-seg))))

(disable definedp-litatom-lr-proper-p-areas)

(prove-lemma MEMBER-LR-FREE-LIST-NODES-TYPE-ADDR (rewrite)
  (implies (not (equal (type (fetch (add-addr addr (lr-ref-count-offset))
				    data-seg))
		       'addr))
	   (not (member addr (lr-free-list-nodes max-addr data-seg)))))

(disable member-lr-free-list-nodes-type-addr)

(prove-lemma LESSP-LENGTH-DEPOSIT (rewrite)
  (not (lessp (length (cdr (assoc name (deposit any addr data-seg))))
	      (length (cdr (assoc name data-seg)))))
  ((enable deposit
	   my-length-put)))

;; GET
(prove-lemma DEFINEDP-LISTP-CDR-ASSOC-LR-PROPER-P-AREASP (rewrite)
  (implies (lr-proper-p-areasp data-seg)
	   (equal (listp (cdr (assoc area-name data-seg)))
		  (definedp area-name data-seg))))

(disable definedp-listp-cdr-assoc-lr-proper-p-areasp)

;; LR-MINIMUM-HEAPP
(prove-lemma LR-MINIMUM-HEAPP-OPENER-ADPP-LR-F-ADDR (rewrite)
  (implies (lr-minimum-heapp data-seg)
	   (adpp (identity (untag (lr-F-addr))) data-seg))
  ((enable lr-minimum-heapp)))

(prove-lemma LR-MINIMUM-HEAPP-OPENER-ADPP-LR-T-ADDR (rewrite)
  (implies (lr-minimum-heapp data-seg)
	   (adpp (identity (untag (lr-T-addr))) data-seg))
  ((enable lr-minimum-heapp)))

(prove-lemma LR-MINIMUM-HEAPP-OPENER-ADPP-LR-0-ADDR (rewrite)
  (implies (lr-minimum-heapp data-seg)
	   (adpp (identity (untag (lr-0-addr))) data-seg))
  ((enable lr-minimum-heapp)))

(prove-lemma LR-MINIMUM-HEAPP-OPENER-ADPP-LR-UNDEF-ADDR (rewrite)
  (implies (lr-minimum-heapp data-seg)
	   (adpp (identity (untag (lr-undef-addr))) data-seg))
  ((enable lr-minimum-heapp)))

(prove-lemma LR-BOUNDARY-OFFSETP-SUB1-LENGTH-HEAP-NAME (rewrite)
  (implies (lr-boundary-nodep (lr-max-node data-seg))
	   (lr-boundary-offsetp
	    (sub1 (length (cdr (assoc (identity (lr-heap-name))
				      data-seg))))))
  ((enable lr-boundary-nodep)))

(prove-lemma LESSP-LR-BOUNDARY-OFFSETP-NODEP-PLUS-NODE-SIZE-FACT-2 (rewrite)
  (implies (and (lr-boundary-offsetp offset1)
		(lr-boundary-offsetp offset2)
		(lessp n (lr-node-size)))
	   (equal (lessp (plus n offset1) offset2)
		  (lessp offset1 offset2))))

(prove-lemma LR-BOUNDARY-OFFSETP-TIMES-LR-NODE-SIZE-ANYTHING (rewrite)
  (lr-boundary-offsetp (times (identity (lr-node-size)) x)))

(prove-lemma LR-BOUNDARY-OFFSETP-DIFFERENCE-NOT-EQUAL-LESSP-FACT-2 ()
  (implies (and (lr-boundary-offsetp x)
		(lr-boundary-offsetp y)
		(numberp x)
		(lessp x y))
	   (equal (lessp (difference y (lr-node-size)) x) f))
  ((disable difference-add1-arg2)))

(prove-lemma LR-MINIMUM-HEAPP-OPENER-2 (rewrite)
  (implies (lr-minimum-heapp data-seg)
	   (lessp (identity (lr-minimum-heap-size))
		  (length (cdr (assoc (identity (lr-heap-name))
				      data-seg)))))
  ((enable lr-minimum-heapp)
   (use (adpp-untag-lessp-offset
	 (addr (add-addr (lr-0-addr) (lr-node-size)))
	 (data-seg data-seg)))))

(disable lr-minimum-heapp-opener-2)

(prove-lemma LR-MINIMUM-HEAPP-OPENER-3 (rewrite)
  (implies (lr-minimum-heapp data-seg)
	   (definedp (identity (lr-heap-name)) data-seg))
  ((use (adpp-untag-definedp-area-name
	 (addr (lr-undef-addr)) (data-seg data-seg)))))

(disable lr-minimum-heapp-opener-3)

;; LR-PROPER-FREE-LISTP
(defn LR-NODE-LISTP (list data-seg)
  (if (listp list)
      (and (lr-nodep (car list) data-seg)
	   (lr-node-listp (cdr list) data-seg))
      t))

(disable lr-node-listp)

(prove-lemma ADPP-ADPP-SUB-ADDR (rewrite)
  (implies (adpp (untag addr) data-seg)
	   (adpp (untag (sub-addr addr n)) data-seg))
  ((enable adpp offset)))

(prove-lemma LR-NODE-LISTP-LR-FREE-LIST-NODES (rewrite)
  (implies (and (lr-boundary-nodep addr)
		(equal (area-name addr) (lr-heap-name))
		(adpp (untag addr) data-seg2)
		(equal (type addr) 'addr))
	   (lr-node-listp (lr-free-list-nodes addr data-seg1) data-seg2))
  ((enable lr-node-listp)
   (disable difference-add1-arg2)))

(prove-lemma LR-NODEP-MEMBER-LR-NODE-LISTP (rewrite)
  (implies (and (lr-node-listp list data-seg)
		(member node list))
	   (and (equal (type node) 'addr)
		(equal (cddr node) nil)
		(listp node)
		(adpp (untag node) data-seg)
		(lr-boundary-nodep node)
		(equal (area-name node) (lr-heap-name))))
  ((enable lr-node-listp)))

(disable lr-nodep-member-lr-node-listp)

(prove-lemma LR-MAX-NODE-LR-NODEP-OPENER-FACTS (rewrite)
  (and (equal (type (lr-max-node data-seg)) 'addr)
       (equal (cddr (lr-max-node data-seg)) nil)
       (equal (area-name (lr-max-node data-seg)) (lr-heap-name))))

(prove-lemma LR-MAX-NODE-ADPP-DEFINEDP-LR-HEAP-NAME (rewrite)
  (implies (lr-proper-p-areasp data-seg)
	   (equal (adpp (untag (lr-max-node data-seg)) data-seg)
		  (definedp (lr-heap-name) data-seg)))
  ((enable adpp
	   definedp-listp-cdr-assoc-lr-proper-p-areasp)))

(prove-lemma OFFSET-LR-MAX-NODE (rewrite)
  (equal (offset (lr-max-node data-seg))
	 (sub1 (length (cdr (assoc (identity (lr-heap-name)) data-seg))))))

(disable lr-max-node)

(prove-lemma LR-PROPER-FREE-LISTP-OPENER-1 (rewrite)
  (implies (lr-proper-free-listp data-seg)
	   (adpp (identity (untag (lr-fp-addr))) data-seg))
  ((enable lr-proper-free-listp)))

(prove-lemma LR-PROPER-FREE-LISTP-OPENER-2 (rewrite)
  (implies (and (lr-proper-free-listp data-seg)
		(adpp (untag (lr-max-node data-seg)) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg)))
	   (and (equal (type (fetch (identity (lr-FP-addr)) data-seg))
		       'addr)
		(equal (cddr (fetch (identity (lr-FP-addr)) data-seg)) nil)
		(listp (fetch (identity (lr-FP-addr)) data-seg))
		(adpp (untag (fetch (identity (lr-FP-addr)) data-seg))
		      data-seg)
		(lr-boundary-nodep (fetch (identity (lr-FP-addr)) data-seg))
		(equal (area-name (fetch (identity (lr-FP-addr)) data-seg))
		       (lr-heap-name))))
  ((enable lr-proper-free-listp
	   lr-node-listp-lr-free-list-nodes)
   (use (lr-nodep-member-lr-node-listp
	 (list (lr-free-list-nodes (lr-max-node data-seg) data-seg))
	 (node (lr-fetch-fp data-seg))
	 (data-seg data-seg)))))

(prove-lemma LR-PROPER-FREE-LISTP-OPENER-2-ADPP-UNTAG-NUMBERP-OFFSET (rewrite)
  (implies (and (lr-proper-free-listp data-seg)
		(adpp (untag (lr-max-node data-seg)) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg)))
	   (numberp (offset (fetch (identity (lr-FP-addr)) data-seg))))
  ((use (adpp-untag-numberp-offset (addr (fetch (lr-FP-addr) data-seg))
				   (data-seg data-seg)))))

(prove-lemma LR-PROPER-FREE-LISTP-OPENER-2-ADPP-UNTAG-LISTP (rewrite)
  (implies (and (lr-proper-free-listp data-seg)
		(adpp (untag (lr-max-node data-seg)) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg)))
	   (listp (untag (fetch (identity (lr-FP-addr)) data-seg))))
  ((use (adpp-untag-listp (addr (fetch (lr-FP-addr) data-seg))
			  (data-seg data-seg)))))

(prove-lemma PLUS-TIMES-FACT-1 (rewrite)
  (implies (not (zerop n))
	   (equal (lessp (plus n (times n w)) (times d n))
		  (lessp (add1 w) d)))
  ((disable-theory addition multiplication)
   (enable times-zero times-add1 commutativity-of-times lessp-times3
	   correctness-of-cancel-lessp-times plus-zero-arg2
	   correctness-of-cancel-lessp-plus)))

(disable plus-times-fact-1)

(prove-lemma LESSP-DIFFERENCE-FACT-1 ()
  (implies (and (equal (remainder x n) 0)
		(equal (remainder y n) 0)
		(lessp x y)
		(numberp x))
	   (equal (lessp x (difference y n))
		  (not (equal x (difference y n)))))
  ((disable-theory addition quotients multiplication)
   (enable plus-times-fact-1 plus-add1-arg1
	   correctness-of-cancel-lessp-plus
	   commutativity-of-times correctness-of-cancel-lessp-times
	   correctness-of-cancel-equal-times lessp-plus-times1 times-add1
	   difference-elim
	   remainder-quotient-elim)
   (induct (remainder x n))))

(prove-lemma LESSP-DIFFERENCE-LR-BOUNDARY-OFFSETP-FACT-1 (rewrite)
  (implies (and (numberp offset)
		(lr-boundary-offsetp offset)
		(lr-boundary-offsetp y)
		(lessp offset y))
	   (equal (lessp offset (difference y (identity (lr-node-size))))
		  (not (equal offset
			      (difference y (identity (lr-node-size)))))))
  ((enable adpp-untag-numberp-offset)
   (disable difference-add1-arg2 difference-leq-arg1)
   (do-not-induct t)
   (use (lessp-difference-fact-1 (x offset) (y y) (n (lr-node-size))))))

(prove-lemma LESSP-LR-NODE-ON-BOUNDARYP-NODE-SIZE (rewrite)
  (implies (and (lr-boundary-nodep addr)
		(numberp (offset addr)))
	   (equal (lessp (offset addr) (identity (lr-node-size)))
		  (equal (offset addr) 0)))
  ((enable lr-boundary-nodep)))

(prove-lemma LESSP-DIFFERENCE-NODE-SIZE-SUB-ADDR (rewrite)
  (implies (and (lessp (offset addr) (offset max-addr))
		(equal (area-name addr) (area-name max-addr))
		(lr-boundary-nodep max-addr)
		(equal (type max-addr) 'addr)
		(numberp (offset max-addr))
		(equal (cddr max-addr) nil)
		(lr-boundary-nodep addr)
		(equal (type addr) 'addr)
		(numberp (offset addr))
		(equal (cddr addr) nil)
		(listp (untag addr)))
	   (equal (lessp (offset addr)
			 (difference (offset max-addr)
				     (identity (lr-node-size))))
		  (not (equal (sub-addr max-addr (identity (lr-node-size)))
			      addr))))
  ((disable-theory addition)
   (enable area-name lr-boundary-nodep offset sub-addr tag type untag)
   (disable lr-boundary-offsetp)))

(prove-lemma LR-NODEP-LR-PROPER-HEAPP-NODEP ()
  (implies (and (lr-proper-heapp2 max-addr data-seg)		
		(lessp (offset addr) (offset max-addr))
		(lr-nodep max-addr data-seg)
		(lr-nodep addr data-seg))
	   (lr-proper-heapp-nodep addr data-seg))
  ((disable difference-add1-arg2 difference)
   (enable adpp-untag-listp
	   adpp-untag-numberp-offset)
   (induct (lr-proper-heapp2 max-addr data-seg))))

(disable lessp-difference-node-size-sub-addr)

(prove-lemma ADPP-AREA-NAME-OFFSET-SAME ()
  (implies (and (listp (untag addr1))
		(numberp (offset addr1))
		(equal (cddr addr1) nil)
		(listp (untag addr2))
		(numberp (offset addr2))
		(equal (cddr addr2) nil)
		(equal (type addr1) (type addr2)))
	   (equal (equal addr1 addr2)
		  (and (equal (offset addr1) (offset addr2))
		       (equal (area-name addr1) (area-name addr2)))))
  ((enable adpp area-name offset tag type untag)))

(prove-lemma LR-PROPER-HEAPP-NODEP-TAG-CONS ()
  (implies (and (equal (untag (fetch addr data-seg))
		       (lr-cons-tag))
		(equal (type (fetch (add-addr addr (lr-ref-count-offset))
				    data-seg))
		       'nat)
		(lr-proper-heapp-nodep addr data-seg)
		(or (equal offset (lr-car-offset))
		    (equal offset (lr-cdr-offset))))
	   (lr-good-pointerp (fetch (add-addr addr offset) data-seg)
			     data-seg))
  ((enable lr-proper-heapp-nodep lr-check-listp-addrp)))

(prove-lemma ADPP-ADD-ADDR-FACT-2 ()
  (implies (and (adpp (untag addr1) data-seg)
		(adpp (untag (add-addr addr1 n)) data-seg)
		(adpp (untag addr2) data-seg)
		(not (adpp (untag (add-addr addr2 n)) data-seg))
		(equal (area-name addr1) (area-name addr2)))
	   (lessp (offset addr1) (offset addr2)))
  ((enable area-name adpp offset)
   (disable adp-name adp-offset definedp length value)
   (disable-theory addition)))

(prove-lemma FETCH-LR-NODEP-ADD-ADDR (rewrite)
  (implies (and (not (adpp (untag (add-addr addr n)) data-seg))
		(lr-nodep addr data-seg))
	   (equal (fetch (add-addr addr n) data-seg) 0))
  ((enable adpp area-name fetch offset
	   definedp-assoc-fact-1
	   get-anything-nil)
   (disable adp-name adp-offset definedp length)
   (disable-theory addition)
   (use (get-large-index (n (offset (add-addr addr n)))
			 (list (value (area-name addr) data-seg))))))

(disable fetch-lr-nodep-add-addr)

(prove-lemma UNTAG-ADDR-ADDR-TAG (rewrite)
  (equal (untag (add-addr (tag tag adp) n))
	 (cons (car adp) (plus (cdr adp) n)))
  ((enable untag add-addr tag)))

(prove-lemma LR-GOOD-POINTERP-LESSP-OFFSET-MAX-HEAP-NODE (rewrite)
  (implies (and (adpp (untag addr) data-seg)
		(lr-boundary-nodep addr)
		(listp addr)
		(equal (cddr addr) nil)
		(equal (type addr) 'addr)
		(equal (area-name addr) 'heap)
		(equal (type (fetch (add-addr addr (lr-ref-count-offset))
				    data-seg))
		       'nat)
		(adpp (untag (lr-max-node data-seg)) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg)))
	   (lessp (offset addr)
		  (sub1 (length (cdr (assoc (identity (lr-heap-name))
					    data-seg))))))
  ((enable adpp
	   fetch-lr-nodep-add-addr)
   (use (adpp-add-addr-fact-2 (addr1 addr)
			      (addr2 (lr-max-node data-seg))
			      (data-seg data-seg)
			      (n (lr-ref-count-offset))))))

(disable lr-good-pointerp-lessp-offset-max-heap-node)

(prove-lemma LR-PROPER-HEAPP-OPENER-1 (rewrite)
  (implies (lr-proper-heapp data-seg)
	   (and (lr-minimum-heapp data-seg)
		(lr-proper-free-listp data-seg)))
  ((enable lr-proper-heapp)))

(prove-lemma LR-PROPER-HEAPP-OPENER-3 (rewrite)
  (implies (and (equal addr (lr-max-node data-seg))
		(lr-proper-heapp data-seg))
	   (lr-proper-heapp2 addr data-seg))
  ((enable lr-proper-heapp lr-proper-heapp1)))

(prove-lemma DEPOSIT-FREE-PTR-PRESERVES-LR-VALP (rewrite)
  (implies (and (adpp (untag (lr-FP-addr)) data-seg)
		(lr-valp value addr data-seg))
	   (lr-valp value
		    addr
		    (deposit anything (identity (lr-FP-addr)) data-seg)))
  ((enable adpp-deposit-anything-at-all
	   adpp-untag-numberp-offset)
   (disable-theory addition)))

(prove-lemma LR-PROPER-P-AREASP-DEPOSIT-ANYTHING-ANYWHERE (rewrite)
  (implies (lr-proper-p-areasp data-seg)
	   (lr-proper-p-areasp (deposit anything addr data-seg)))
  ((enable area-name deposit)))

(prove-lemma LR-NODE-LISTP-DELETE (rewrite)
  (implies (lr-node-listp list data-seg)
	   (lr-node-listp (delete anything list) data-seg))
  ((enable lr-node-listp)))

(disable lr-node-listp-delete)

(prove-lemma LR-NODE-LISTP-DEPOSIT-ANYTHING-AT-ALL (rewrite)
  (implies (lr-node-listp addr data-seg)
	   (lr-node-listp addr (deposit anything addr2 data-seg)))
  ((enable lr-node-listp
	   adpp-deposit-anything-at-all)))

(disable lr-node-listp-deposit-anything-at-all)

(prove-lemma CDR-ASSOC-MEMBER-STRIP-CDRS (rewrite)
  (implies (definedp name list)
	   (member (cdr (assoc name list)) (strip-cdrs list))))

(disable cdr-assoc-member-strip-cdrs)

(prove-lemma LR-SET-ERROR-LR->P (rewrite)
  (equal (lr->p (lr-set-error p flag))
	 (lr-set-error (lr->p p) flag))
  ((enable lr->p lr-set-error lr-p-pc p-current-program)
   (disable lr-p-pc-1)))

(prove-lemma LR-PARAMS-LR-SET-EXPR (rewrite)
  (implies (and (equal (area-name (p-pc l)) (area-name (p-pc l2)))
		(equal (p-prog-segment l) (p-prog-segment l2)))
	   (equal (lr-params frame (lr-set-expr l l2 pos))
		  (lr-params frame l)))
  ((enable lr-params p-current-program)))

(prove-lemma LR-TEMPS-LR-SET-EXPR (rewrite)
  (implies (and (equal (area-name (p-pc l)) (area-name (p-pc l2)))
		(equal (p-prog-segment l) (p-prog-segment l2)))
	   (equal (lr-temps frame (lr-set-expr l l2 pos))
		  (lr-temps frame l)))
  ((enable lr-temps p-current-program)))

(prove-lemma P-CURRENT-PROGRAM-LR-PUSH-TSTK (rewrite)
  (equal (p-current-program (lr-push-tstk l any)) (p-current-program l))
  ((enable p-current-program)))

(prove-lemma P-CURRENT-PROGRAM-LR-SET-TEMP (rewrite)
  (equal (p-current-program (lr-set-temp l value var))
	 (p-current-program l))
  ((enable p-current-program)))

(prove-lemma P-CURRENT-PROGRAM-LR-POP-TSTK (rewrite)
  (equal (p-current-program (lr-pop-tstk l)) (p-current-program l))
  ((enable p-current-program)))

(prove-lemma P-CURRENT-PROGRAM-LR-DO-TEMP-FETCH (rewrite)
  (equal (p-current-program (lr-do-temp-fetch l)) (p-current-program l))
  ((enable p-current-program)))

(prove-lemma STRIP-CARS-RESTN (rewrite)
  (equal (strip-cars (restn n list)) (restn n (strip-cars list)))
  ((disable append-firstn-restn)))

(disable strip-cars-restn)

(prove-lemma STRIP-CARS-FIRSTN (rewrite)
  (equal (strip-cars (firstn n list)) (firstn n (strip-cars list)))
  ((disable append-firstn-restn)))

(disable strip-cars-firstn)

(prove-lemma LR-PARAMS-LR-POP-TSTK (rewrite)
  (equal (lr-params frame (lr-pop-tstk l)) (lr-params frame l))
  ((enable lr-params)))

(prove-lemma LR-TEMPS-LR-POP-TSTK (rewrite)
  (equal (lr-temps frame (lr-pop-tstk l)) (lr-temps frame l))
  ((enable lr-temps)))

(prove-lemma LR-MINIMUM-HEAPP-SAME-SIGNATURE (rewrite)
  (implies (same-signature data-seg1 data-seg2)
	   (equal (lr-minimum-heapp data-seg2)
		  (lr-minimum-heapp data-seg1)))
  ((enable lr-minimum-heapp)
   (use (adpp-same-signature
	 (adp (untag (lr-undef-addr)))
	 (data-seg1 data-seg2) (data-seg2 data-seg1))
	(adpp-same-signature
	 (adp (untag (lr-f-addr)))
	 (data-seg1 data-seg2) (data-seg2 data-seg1))
	(adpp-same-signature
	 (adp (untag (lr-t-addr)))
	 (data-seg1 data-seg2) (data-seg2 data-seg1))
	(adpp-same-signature
	 (adp (untag (lr-0-addr)))
	 (data-seg1 data-seg2) (data-seg2 data-seg1))
	(adpp-same-signature
	 (adp (untag (add-addr (lr-0-addr) (lr-node-size))))
	 (data-seg1 data-seg2) (data-seg2 data-seg1)))))

(disable lr-minimum-heapp-same-signature)

(prove-lemma PUT-NOT-LISTP ()
  (implies (and (not (listp list1))
		(not (listp list2)))
	   (equal (put val n list1) (put val n list2)))
  ((enable put)))

(prove-lemma PUT-ZERO (rewrite)
  (equal (put val n 0) (put val n nil))
  ((use (put-not-listp (list1 0) (list2 nil) (val val) (n n)))))

(disable put-zero)

(prove-lemma PUT-PUT ()
  (implies (and (numberp offset1)
		(numberp offset2))
	   (equal (put val1 offset1 (put val2 offset2 list))
		  (if (equal offset1 offset2)
		      (put val1 offset1 list)
		      (put val2 offset2 (put val1 offset1 list)))))
  ((enable put put-zero)))

(prove-lemma PROPER-P-DATA-SEGMENTP-IMPLIES-LR-PROPER-P-AREASP (rewrite)
  (implies (proper-p-data-segmentp data-seg p)
	   (lr-proper-p-areasp data-seg)))

(prove-lemma PROPER-P-STATEP-LR->P-IMPLIES-LR-PROPER-P-AREASP (rewrite)
  (implies (proper-p-statep (lr->p l))
	   (lr-proper-p-areasp (p-data-segment l)))
  ((enable proper-p-statep)
   (disable exp definedp p-ctrl-stk-size proper-p-alistp
	    proper-p-ctrl-stkp proper-p-data-segmentp proper-p-temp-stkp
	    proper-p-prog-segmentp)))

(disable proper-p-data-segmentp-implies-lr-proper-p-areasp)

(prove-lemma LR-PROPER-FREE-LISTP-TYPE-FETCH-FREE-PTR (rewrite)
  (implies (and (lr-proper-free-listp data-seg)
		(adpp (untag (lr-max-node data-seg)) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg))
		(lr-proper-p-areasp data-seg))
	   (not (equal (type (fetch (add-addr (fetch (identity (lr-fp-addr))
						     data-seg)
					      (identity
					       (lr-ref-count-offset)))
				    data-seg))
		       'nat)))
  ((enable lr-proper-free-listp
	   definedp-listp-cdr-assoc-lr-proper-p-areasp
	   fetch-lr-nodep-add-addr
	   member-lr-free-list-nodes-type-addr)
   (use (adpp-untag-lessp-offset (addr (add-addr (fetch (lr-fp-addr)
							data-seg)
						 (lr-ref-count-offset)))
				 (data-seg data-seg)))))

(prove-lemma PUT-ASSOC-PUT-ASSOC-1 (rewrite)
  (equal (put-assoc val1 name (put-assoc val2 name alist))
	 (put-assoc val1 name alist)))

(prove-lemma PUT-ASSOC-PUT-ASSOC-2 ()
  (equal (put-assoc val1 name1 (put-assoc val2 name2 alist))
	 (if (equal name1 name2)
	     (put-assoc val1 name1 alist)
	     (put-assoc val2 name2 (put-assoc val1 name1 alist)))))

(prove-lemma DEPOSIT-DEPOSIT ()
  (implies (and (numberp (offset addr1))
		(numberp (offset addr2)))
	   (equal (deposit value1 addr1 (deposit value2 addr2 data-seg))
		  (if (and (equal (area-name addr1) (area-name addr2))
			   (equal (offset addr1) (offset addr2)))
		      (deposit value1 addr1 data-seg)
		      (deposit value2
			       addr2
			       (deposit value1 addr1 data-seg)))))
  ((enable area-name deposit offset type untag
	   assoc-put-assoc-3)
   (use (put-put (val1 value1)
		 (offset1 (offset addr1))
		 (val2 value2)
		 (offset2 (offset addr2))
		 (list (value (area-name addr2) data-seg)))
	(put-assoc-put-assoc-2 (val1 (put value1
					  (offset addr1)
					  (value (area-name addr1)
						 data-seg)))
			       (name1 (area-name addr1))
			       (val2 (put value2
					  (offset addr2)
					  (value (area-name addr2)
						 data-seg)))
			       (name2 (area-name addr2))
			       (alist data-seg)))))

(prove-lemma DEPOSIT-REF-COUNT-MOVE-OUTWARD (rewrite)
  (implies (numberp (offset addr))
	   (equal (deposit value1
			   addr
			   (deposit value2
				    (add-addr addr
					      (identity
					       (lr-ref-count-offset)))
				    data-seg))
		  (deposit value2
			   (add-addr addr (lr-ref-count-offset))
			   (deposit value1 addr data-seg))))
  ((use (deposit-deposit (addr1 addr)
			 (addr2 (add-addr addr (lr-ref-count-offset)))
			 (value1 value1)
			 (value2 value2)
			 (data-seg data-seg)))))

(defn IHINT-2 (flag s l table c)
  (cond ((not (equal (s-err-flag s) 'run)) t)
	((equal flag 'list)
	 (if (nlistp (s-pos s))
	     t
	     (if (listp (s-expr-list s))
		 (and (ihint-2 t s l table c)
		      (ihint-2 'list
			       (s-set-expr (s-eval t s c) s (nx (s-pos s)))
			       (lr-eval t (s->lr1 s l table) c)
			       table
			       c))
		 t)))
	((zerop c) t)
	((litatom (s-expr s)) t)
	((nlistp (s-expr s)) t)
	((equal (car (s-expr s)) 'if)
	 (let ((lrtest (lr-if-ok (lr-eval t
					  (s->lr1 (s-set-pos s
							     (dv (s-pos s)
								 1))
						  l
						  table)
					  c)))
	       (stest (s-eval t (s-set-pos s (dv (s-pos s) 1)) c)))
	   (if (equal (p-psw lrtest) 'run)
	       (if (not (equal (top (p-temp-stk lrtest)) (lr-f-addr)))
		   (and (ihint-2 t (s-set-pos s (dv (s-pos s) 1)) l table c)
			(ihint-2 t
				 (s-set-expr stest s (dv (s-pos s) 2))
				 (lr-pop-tstk lrtest)
				 table
				 c))
		   (and (ihint-2 t (s-set-pos s (dv (s-pos s) 1)) l table c)
			(ihint-2 t
				 (s-set-expr stest s (dv (s-pos s) 3))
				 (lr-pop-tstk lrtest)
				 table
				 c)))
	       (ihint-2 t (s-set-pos s (dv (s-pos s) 1)) l table c))))
	((equal (car (s-expr s)) (s-temp-eval))
	 (ihint-2 t (s-set-pos s (dv (s-pos s) 1)) l table c))
	((equal (car (s-expr s)) (s-temp-test))
	 (if (not (lessp (p-max-temp-stk-size l)
			 (plus 2 (length (p-temp-stk l)))))
	     (if (lr-eval-temp-setp (s->lr1 s l table))
		 t
		 (ihint-2 t (s-set-pos s (dv (s-pos s) 1)) l table c))
	     t))
	((equal (car (s-expr s)) (s-temp-fetch)) t)
	((equal (car (s-expr s)) 'quote) t)
	((not (equal (s-err-flag (s-eval 'list
					 (s-set-pos s (dv (s-pos s) 1))
					 c))
		     'run))
	 (ihint-2 'list (s-set-pos s (dv (s-pos s) 1)) l table c))
	((subrp (car (s-expr s)))
	 (ihint-2 'list (s-set-pos s (dv (s-pos s) 1)) l table c))
	((litatom (car (s-expr s)))
	 (let ((s-arg-s (s-eval 'list (s-set-pos s (dv (s-pos s) 1)) c))
	       (lr-arg-s (lr-eval 'list
				  (s->lr1 (s-set-pos s (dv (s-pos s) 1)) l
					  table)
				  c)))
	   (and (ihint-2 'list (s-set-pos s (dv (s-pos s) 1)) l table c)
		(ihint-2 t
			 (s-fun-call-state s-arg-s (car (s-expr s)))
			 (lr-funcall (s->lr1 s l table) lr-arg-s)
			 table
			 (sub1 c)))))
	(t t))
  ((ord-lessp (cons (add1 c) (if (equal flag 'list)
				 (number-cons (s-expr-list s))
				 (number-cons (s-expr s)))))))

(defn INDUCT-HINT-4 (x temp-stk)
  (if (listp x)
      (induct-hint-4 (cdr x) (cdr temp-stk))
      t))

(prove-lemma LR-CHECK-RESULT1-APPEND (rewrite)
  (equal (lr-check-result1 (append x y) temp-stk data-seg)
	 (and (lr-check-result1 x temp-stk data-seg)
	      (lr-check-result1 y (restn (length x) temp-stk) data-seg)))
  ((induct (induct-hint-4 x temp-stk))))

(prove-lemma LR-PROPER-HEAPP-OPENER-4 (rewrite)
  (implies (lr-proper-heapp data-seg)
	   (and (adpp (untag (lr-max-node data-seg)) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg))))
  ((enable lr-proper-heapp)))

(prove-lemma LENGTH-STRIP-CARS (rewrite)
  (equal (length (strip-cars temp-vars)) (length temp-vars)))

(prove-lemma DEFINEDP-LR-COMPILE-PROGRAMS (rewrite)
  (equal (definedp name (lr-compile-programs progs const-table))
	 (definedp name progs)))

(prove-lemma LR-VALP-DEPOSIT-FETCH-FREE-POINTER-OFFSET-HELPER-1 (rewrite)
  (implies (and (equal (type (fetch (add-addr addr
					      (identity
					       (lr-ref-count-offset)))
				    data-seg))
		       'nat)
		(lr-good-pointerp addr data-seg)
		(lr-nodep free-addr data-seg)
		(equal (offset addr) (offset free-addr)))
	   (equal (type (fetch (add-addr free-addr
					 (identity (lr-ref-count-offset)))
			       data-seg))
		  'nat))
  ((use (adpp-area-name-offset-same (addr1 addr) (addr2 free-addr)))
   (enable adpp-untag-listp
	   adpp-untag-numberp-offset)
   (disable plus
	    plus-add1-arg1 plus-add1-arg2)))

(prove-lemma LR-BOUNDARY-NODEP-EQUAL-PLUS-FACT-ZERO (rewrite)
  (implies (and (equal (type addr1) 'addr)
		(equal (cddr addr1) nil)
		(listp addr1)
		(listp (untag addr1))
		(numberp (offset addr1))
		(lr-boundary-nodep addr1)
		(equal (type addr2) 'addr)
		(equal (cddr addr2) nil)
		(listp addr2)
		(listp (untag addr2))
		(numberp (offset addr2))
		(lr-boundary-nodep addr2)
		(equal (area-name addr2) (area-name addr1))
 		(lessp m (lr-node-size)))
	   (equal (equal (offset addr1) (plus m (offset addr2)))
		  (and (zerop m)
		       (equal addr1 addr2))))
  ((disable-theory addition quotients)
   (enable lr-boundary-nodep)
   (use (lr-boundary-offsetp-equal-plus-fact
	 (offset1 (offset addr1)) (offset2 (offset addr2))
	 (max (lr-node-size)) (n 0) (m m))
	(adpp-area-name-offset-same (addr1 addr1) (addr2 addr2)))))

(prove-lemma LR-BOUNDARY-NODEP-EQUAL-PLUS-FACT (rewrite)
  (implies (and (equal (type addr1) 'addr)
		(equal (cddr addr1) nil)
		(listp addr1)
		(listp (untag addr1))
		(numberp (offset addr1))
		(lr-boundary-nodep addr1)
		(equal (type addr2) 'addr)
		(equal (cddr addr2) nil)
		(listp addr2)
		(listp (untag addr2))
		(numberp (offset addr2))
		(lr-boundary-nodep addr2)
		(lessp n (lr-node-size))
		(lessp m (lr-node-size))
		(equal (area-name addr1) (area-name addr2)))
	   (equal (equal (plus n (offset addr1))
			 (plus m (offset addr2)))
		  (and (equal (fix n) (fix m))
		       (equal addr1 addr2))))
  ((enable lr-boundary-nodep)
   (disable-theory addition quotients)
   (use (lr-boundary-offsetp-equal-plus-fact
	 (offset1 (offset addr1)) (offset2 (offset addr2))
	 (max (lr-node-size)) (n n) (m m))
	(adpp-area-name-offset-same (addr1 addr1) (addr2 addr2)))))

(prove-lemma LR-VALP-DEPOSIT-FETCH-FREE-POINTER-OFFSET (rewrite)
  (implies (and (not (equal (type (fetch (add-addr free-addr
						   (lr-ref-count-offset))
					 data-seg))
			    'nat))
		(lr-nodep free-addr data-seg)
		(lessp n (lr-node-size))
		(lr-valp value addr data-seg))
	   (lr-valp value
		    addr
		    (deposit anything (add-addr free-addr n) data-seg)))
  ((enable adpp-deposit-anything-at-all
	   adpp-untag-definedp-area-name
	   adpp-untag-listp
	   adpp-untag-numberp-offset)
   (disable plus
	    plus-add1-arg1 plus-add1-arg2)))

(disable lr-valp-deposit-fetch-free-pointer-offset)
(disable lr-valp-deposit-fetch-free-pointer-offset-helper-1)

(prove-lemma LR-VALP-DEPOSIT-FETCH-FREE-POINTER (rewrite)
  (implies (and (not (equal (type (fetch (add-addr free-addr
						   (lr-ref-count-offset))
					 data-seg))
			    'nat))
		(lr-nodep free-addr data-seg)
		(lr-valp value addr data-seg))
	   (lr-valp value addr (deposit anything free-addr data-seg)))
  ((use (lr-valp-deposit-fetch-free-pointer-offset (n 0)
						   (addr addr)
						   (data-seg data-seg)
						   (free-addr free-addr)
						   (value value)
						   (anything anything)))
   (enable adpp-add-addr-0)))

(disable lr-valp-deposit-fetch-free-pointer)

(prove-lemma NOT-EQUAL-X-ADD1-ADD1-X (rewrite)
  (equal (equal x (add1 (add1 x))) f))

(prove-lemma NOT-EQUAL-X-ADD1-X (rewrite)
  (equal (equal x (add1 x)) f))

(prove-lemma P-RUN-SUBR-PRESERVES-LR-VALP (rewrite)
  (implies (and (good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(lr-programs-properp new-l table)
		(listp (lr-expr l))
		(proper-p-statep (lr->p new-l))
		(lr-proper-free-listp (p-data-segment new-l))
		(adpp (untag (lr-max-node (p-data-segment new-l)))
		      (p-data-segment new-l))
		(lr-boundary-nodep (lr-max-node (p-data-segment new-l)))
		(equal (p-psw new-l) 'run)
		(equal (p-psw (p-run-subr (car (lr-expr l))
					  (p-set-pc (lr->p new-l)
						    (lr-return-pc l))))
		       'run)
		(lr-valp value addr (p-data-segment new-l))
		(equal (p-prog-segment l) (p-prog-segment new-l)))
	   (lr-valp value
		    addr
		    (p-data-segment
		     (p-run-subr (car (lr-expr l))
				 (p-set-pc (lr->p new-l)
					   (lr-return-pc l))))))
  ((enable p-run-subr p-current-program
	   adpp-deposit-anything-at-all
	   adpp-untag-definedp-area-name
	   lr-valp-deposit-fetch-free-pointer
	   lr-valp-deposit-fetch-free-pointer-offset)
   (disable length lr-p-c-size lr-p-c-size-list lr-valp
	    program-body-assoc-comp-programs)))

(prove-lemma NUMBERP-OFFSET-SUB-ADDR (rewrite)
  (numberp (offset (sub-addr addr n))))

(prove-lemma LR-FREE-LIST-NODES-DEPOSIT-NON-REF-COUNT (rewrite)
  (implies (and (lr-nodep addr data-seg)
		(lr-nodep max-addr data-seg)
		(not (equal offset (lr-ref-count-offset)))
		(numberp offset)
		(lessp offset (lr-node-size)))
	   (equal (lr-free-list-nodes max-addr
				      (deposit anything
					       (add-addr addr offset)
					       data-seg))
		  (lr-free-list-nodes max-addr data-seg)))
  ((enable adpp-untag-numberp-offset
	   adpp-untag-listp
	   commutativity-of-plus)
   (disable difference plus
	    offset-sub-addr)
   (disable-theory addition)))

(prove-lemma LR-NODEP-MEMBER-LR-NODE-LISTP-ADPP-UNTAG-LISTP (rewrite)
  (implies (and (lr-node-listp list data-seg)
		(member node list))
	   (listp (untag node)))
  ((enable lr-nodep-member-lr-node-listp)
   (use (adpp-untag-listp (addr node) (data-seg data-seg)))))

(disable lr-nodep-member-lr-node-listp-adpp-untag-listp)

(prove-lemma LR-NODEP-MEMBER-LR-NODE-LISTP-ADPP-UNTAG-NUMBERP-OFFSET (rewrite)
  (implies (and (lr-node-listp list data-seg)
		(member node list))
	   (numberp (offset node)))
  ((enable lr-nodep-member-lr-node-listp)
   (use (adpp-untag-numberp-offset (addr node) (data-seg data-seg)))))

(prove-lemma LR-NODEP-MEMBER-LR-NODE-LISTP-LR-BOUNDARYP-OFFSETP (rewrite)
  (implies (and (lr-node-listp list data-seg)
		(member node list))
	   (lr-boundary-offsetp (offset node)))
  ((use (lr-nodep-member-lr-node-listp
	 (list list) (node node) (data-seg data-seg)))
   (enable lr-boundary-nodep)
   (disable lr-boundary-offsetp)))

(prove-lemma LR-CHECK-FREE-NODES-DEPOSIT-NON-REF-COUNT (rewrite)
  (implies (and (lr-nodep addr2 data-seg)
		(lr-nodep max-addr data-seg)
		(not (equal offset (lr-ref-count-offset)))
		(numberp offset)
		(lessp offset (lr-node-size))
		(lr-node-listp node-list data-seg))
	   (equal (lr-check-free-nodes addr1
				       node-list
				       (deposit anything
						(add-addr addr2 offset)
						data-seg)
				       max-addr)
		  (lr-check-free-nodes addr1 node-list data-seg max-addr)))
  ((enable lr-boundary-nodep lr-node-listp-delete
	   adpp-untag-listp
	   adpp-untag-numberp-offset
	   commutativity-of-plus
	   lr-nodep-member-lr-node-listp)
   (disable lr-boundary-offsetp plus difference)
   (disable-theory addition)))

(disable lr-nodep-member-lr-node-listp-adpp-untag-numberp-offset)

(prove-lemma ADPP-DEPOSIT-OTHER-AREA (rewrite)
  (implies (not (equal (adp-name adp) (area-name addr)))
	   (equal (adpp adp (deposit anything addr data-seg))
		  (adpp adp data-seg)))
  ((enable adpp deposit area-name)))

(disable adpp-deposit-other-area)

(prove-lemma LENGTH-DEPOSIT (rewrite)
  (equal (length (cdr (assoc name (deposit anything addr data-seg))))
	 (if (definedp (area-name addr) data-seg)
	     (if (equal (area-name addr) name)
		 (if (lessp (offset addr)
			    (length (cdr (assoc name data-seg))))
		     (length (cdr (assoc name data-seg)))
		     (add1 (offset addr)))
		 (length (cdr (assoc name data-seg))))
	     (length (cdr (assoc name data-seg)))))
  ((enable area-name deposit offset
	   assoc-put-assoc-3
	   definedp-assoc-fact-1
	   my-length-put)))

(prove-lemma SAME-SIGNATURE-DEPOSIT (rewrite)
  (implies (and (adpp (untag addr) segment2)
		(lr-proper-p-areasp segment2))
	   (equal (same-signature segment1 (deposit anything addr segment2))
		  (same-signature segment1 segment2)))
  ((enable area-name deposit offset
	   definedp-litatom-lr-proper-p-areas
	   my-length-put
	   same-signature-put-assoc-2)
   (use (definedp-litatom-lr-proper-p-areas
	  (name (area-name addr)) (data-seg segment2))
	(adpp-untag-definedp-area-name (addr addr) (data-seg segment2))
	(adpp-untag-lessp-offset (addr addr) (data-seg segment2)))))

(prove-lemma LR-MAX-NODE-SAME-SIGNATURE (rewrite)
  (implies (same-signature data-seg1 data-seg2)
	   (equal (lr-max-node data-seg2)
		  (lr-max-node data-seg1)))
  ((enable lr-max-node
	   same-signature-implies-equal-lengths)))

(disable lr-max-node-same-signature)

(prove-lemma LR-MAX-NODE-DEPOSIT (rewrite)
  (implies (and (adpp (untag addr) data-seg)
		(lr-proper-p-areasp data-seg))
	   (equal (lr-max-node (deposit anything addr data-seg))
		  (lr-max-node data-seg)))
  ((use (lr-max-node-same-signature
	 (data-seg1 data-seg)
	 (data-seg2 (deposit anything addr data-seg))))))

(prove-lemma NOT-ADPP-UNTAG-NODE-NOT-DEFINEDP-LR-HEAP-NAME (rewrite)
  (implies (not (definedp (area-name addr) data-seg))
	   (not (adpp (untag addr) data-seg)))
  ((enable adpp area-name)))

(prove-lemma SUB-ADDR-AREA-NAME-OFFSET-SAME (rewrite)
  (implies (and (listp (untag addr1))
		(numberp (offset addr1))
		(equal (cddr addr1) nil)
		(equal (type addr1) (type addr2)))
	   (equal (equal addr1 (sub-addr addr2 n))
		  (and (equal (offset addr1) (difference (offset addr2) n))
		       (equal (area-name addr1) (area-name addr2)))))
  ((use (adpp-area-name-offset-same
	 (addr1 addr1) (addr2 (sub-addr addr2 n))))))

(prove-lemma LR-FREE-LIST-NODES-MEMBER-GREATER-OFFSET (rewrite) 
  (implies (not (lessp (offset addr) (offset max-addr))) 
	   (not (member addr (lr-free-list-nodes max-addr data-seg)))))

(prove-lemma LR-FREE-LIST-NODES-DEPOSIT-LR-REF-COUNT-OFFSET (rewrite)
  (implies (and (equal (type addr) 'addr)
		(equal (cddr addr) nil)
		(adpp (untag addr) data-seg)
		(lr-boundary-nodep addr)
		(equal (area-name addr) 'heap)
		(equal (type max-addr) 'addr)
		(adpp (untag max-addr) data-seg)
		(lr-boundary-nodep max-addr)
		(equal (area-name max-addr) 'heap)
		(equal (type ref-count) 'nat)
		(numberp (untag ref-count)))
	   (equal (lr-free-list-nodes
		   max-addr
		   (deposit ref-count
			    (add-addr addr (identity (lr-ref-count-offset)))
			    data-seg))
		  (delete addr (lr-free-list-nodes max-addr data-seg))))
  ((enable adpp-untag-definedp-area-name
	   adpp-untag-listp
	   adpp-untag-numberp-offset
	   commutativity-of-plus)
   (disable-theory addition)))

(disable lr-free-list-nodes-member-greater-offset)

(disable not-adpp-untag-node-not-definedp-lr-heap-name)

(defn NO-DUPLICATESP (list)
  (if (listp list)
      (if (member (car list) (cdr list))
	  f
	  (no-duplicatesp (cdr list)))
      t))

(prove-lemma NOT-MEMBER-OCCURENCES-0 (rewrite)
  (implies (not (member x z))
	   (equal (occurrences x z) 0)))

(disable not-member-occurences-0)

(prove-lemma NO-DUPLICATESP-OCCURENCES-1 (rewrite)
  (implies (and (no-duplicatesp list)
		(member e list))
	   (equal (occurrences e list) 1))
  ((enable not-member-occurences-0)))

(prove-lemma NO-DUPLICATESP-LR-FREE-LIST-NODES (rewrite)
  (no-duplicatesp (lr-free-list-nodes addr data-seg))
  ((enable lr-free-list-nodes-member-greater-offset)))

(prove-lemma MEMBER-AREA-NAME-OFFSET-SAME (rewrite)
  (implies (and (member addr1 node-list)
		(numberp (offset addr1))
		(equal (cddr addr1) nil)
		(listp (untag addr1))
		(listp (untag addr2))
		(numberp (offset addr2))
		(equal (cddr addr2) nil)
		(equal (type addr1) (type addr2))
		(equal (area-name addr1) (area-name addr2))
		(equal (offset addr2) (offset addr1)))
	   (member addr2 node-list))
  ((use (adpp-area-name-offset-same (addr1 addr1) (addr2 addr2)))))

(prove-lemma LR-CHECK-FREE-NODES-DELETE-DEPOSIT (rewrite)
  (implies (and (lr-check-free-nodes addr2 node-list data-seg max-addr)
		(not (member addr1 node-list))
		(lr-nodep addr1 data-seg)
		(lr-node-listp node-list data-seg)
		(equal (type ref-count) 'nat)
		(numberp (untag ref-count)))
	   (lr-check-free-nodes addr2
				node-list
				(deposit ref-count
					 (add-addr addr1
						   (identity
						    (lr-ref-count-offset)))
					 data-seg)
				max-addr))
  ((enable adpp-untag-definedp-area-name
	   adpp-untag-listp
	   adpp-untag-numberp-offset
	   commutativity-of-plus
	   lr-node-listp-delete
	   lr-nodep-member-lr-node-listp
	   lr-nodep-member-lr-node-listp-adpp-untag-numberp-offset
	   lr-nodep-member-lr-node-listp-adpp-untag-listp)
   (induct (lr-check-free-nodes addr2 node-list data-seg max-addr))
   (expand (lr-check-free-nodes addr2
				node-list
				(deposit ref-count
					 (add-addr addr1
						   (identity
						    (lr-ref-count-offset)))
					 data-seg)
				max-addr))
   (disable-theory addition)))

(disable lr-check-free-nodes-delete-deposit)
(disable member-area-name-offset-same)

(prove-lemma LR-CHECK-FREE-NODES-DEPOSIT-FREE-PTR (rewrite)
  (implies (and (adpp (identity (untag (lr-FP-addr))) data-seg)
		(lr-node-listp node-list data-seg))
	   (equal (lr-check-free-nodes addr
				       node-list
				       (deposit anything
						(identity (lr-fp-addr))
						data-seg)
				       max-addr)
		  (lr-check-free-nodes addr node-list data-seg max-addr)))
  ((enable lr-node-listp-delete)))

(prove-lemma LR-FREE-LIST-NODES-DEPOSIT-FREE-PTR (rewrite)
  (implies (and (lr-nodep max-addr data-seg)
		(adpp (identity (untag (lr-FP-addr))) data-seg))
	   (equal (lr-free-list-nodes max-addr
				      (deposit anything
					       (identity (lr-fp-addr))
					       data-seg))
		  (lr-free-list-nodes max-addr data-seg)))
  ((disable-theory addition)
   (enable commutativity-of-plus)))

(prove-lemma DEPOSIT-REF-COUNT-MOVE-INWARD-2 (rewrite)
  (implies (and (lr-nodep addr data-seg)
		(not (equal offset (lr-ref-count-offset)))
		(not (zerop offset))
		(lessp offset (lr-node-size)))
	   (equal (deposit any1
			   (add-addr addr (identity (lr-ref-count-offset)))
			   (deposit any2
				    (add-addr addr offset)
				    data-seg))
		  (deposit any2
			   (add-addr addr offset)
			   (deposit any1
				    (add-addr addr
					      (identity
					       (lr-ref-count-offset)))
				    data-seg))))
  ((enable adpp-untag-numberp-offset)
   (use (deposit-deposit (value1 any1)
			 (addr1 (add-addr addr (lr-ref-count-offset)))
			 (value2 any2)
			 (addr2 (add-addr addr offset))
			 (data-seg data-seg))
	(adpp-area-name-offset-same
	 (addr1 (add-addr addr (lr-ref-count-offset)))
	 (addr2 (add-addr addr offset))
	 (data-seg data-seg)))
   (disable deposit-ref-count-move-outward)))

(disable deposit-ref-count-move-inward-2)

(prove-lemma LR-FREE-LIST-NODES-DEPOSIT-LR-NODEP (rewrite)
  (implies (and (lr-nodep addr data-seg)
		(lr-nodep max-addr data-seg))
	   (equal (lr-free-list-nodes max-addr
				      (deposit anything addr data-seg))
		  (lr-free-list-nodes max-addr data-seg)))
  ((enable adpp-add-addr-0)
   (use (lr-free-list-nodes-deposit-non-ref-count (addr addr)
						  (offset 0)
						  (max-addr max-addr)
						  (data-seg data-seg)
						  (anything anything)))
   (disable lr-free-list-nodes-deposit-non-ref-count)))

(prove-lemma LR-CHECK-FREE-NODES-DEPOSIT-LR-NODEP (rewrite)
  (implies (and (lr-nodep addr2 data-seg)
		(lr-nodep max-addr data-seg)
		(lr-node-listp node-list data-seg))
	   (equal (lr-check-free-nodes addr1
				       node-list
				       (deposit anything addr2 data-seg)
				       max-addr)
		  (lr-check-free-nodes addr1 node-list data-seg max-addr)))
  ((enable adpp-add-addr-0)
   (use (lr-check-free-nodes-deposit-non-ref-count (addr2 addr2)
						   (max-addr max-addr)
						   (data-seg data-seg)
						   (offset 0)
						   (node-list node-list)
						   (anything anything)))
   (disable lr-check-free-nodes-deposit-non-ref-count)))

(prove-lemma SAME-SIGNATURE-CONS (rewrite)
  (equal (same-signature data-seg1 (cons x data-seg2))
	 (if (listp data-seg1)
	     (and (equal (signature (car data-seg1)) (signature x))
		  (same-signature (cdr data-seg1) data-seg2))
	     f))
  ((expand (same-signature data-seg1 (cons x data-seg2)))))

(prove-lemma SAME-SIGNATURE-NIL (rewrite)
  (implies (nlistp data-seg1)
	   (equal (same-signature data-seg1 data-seg2) (nlistp data-seg2)))
  ((expand (same-signature data-seg1 data-seg2))))

(prove-lemma LISTP-PUT-ASSOC (rewrite)
  (equal (listp (put-assoc val name alist)) (listp alist)))

(prove-lemma NOT-SAME-SIGNATURE-DEPOSIT-TOO-LARGE-ADDR (rewrite)
  (implies (and (definedp (area-name addr) data-seg2)
		(lr-proper-p-areasp data-seg2)		
		(not (lessp (offset addr)
			    (length (value (area-name addr) data-seg1)))))
	   (not (same-signature data-seg1
				(deposit any addr data-seg2))))
  ((induct (same-signature data-seg1 data-seg2))
   (enable area-name deposit offset; same-signature
	   assoc-put-assoc-3
	   my-length-put)
   (expand (put-assoc (put any
			   (cdr (untag addr))
			   (cdr (assoc (caar data-seg1) data-seg2)))
		      (caar data-seg1)
		      data-seg2))))


(disable same-signature-cons)
(disable same-signature-nil)

(prove-lemma ADPP-DEPOSIT-A-LIST (rewrite)
  (implies (adpp adp data-seg)
	   (adpp adp (deposit-a-list list addr2 data-seg)))
  ((enable deposit-a-list
	   adpp-deposit-anything-at-all)))

(prove-lemma LR-PROPER-P-AREASP-DEPOSIT-A-LIST (rewrite)
  (implies (lr-proper-p-areasp data-seg)
	   (lr-proper-p-areasp (deposit-a-list list addr data-seg)))
  ((enable deposit-a-list)))

(prove-lemma DEFINEDP-DEPOSIT-A-LIST (rewrite)
  (equal (definedp tag (deposit-a-list list addr data-seg))
	 (definedp tag data-seg))
  ((enable deposit-a-list)))

(prove-lemma SUB1-PLUS-NOT-ZEROP-FACT-1 (rewrite)
  (implies (not (zerop x))
	   (equal (lessp (sub1 (plus y x)) y) f)))

(prove-lemma NOT-ADPP-UNTAG-ADD-ADDR-ADPP-UNTAG (rewrite)
  (implies (adpp (untag addr) data-seg)
	   (equal (adpp (untag (add-addr addr n)) data-seg)
		  (lessp (plus (offset addr) n)
			 (length (cdr (assoc (area-name addr) data-seg))))))
  ((enable adpp area-name)))

(prove-lemma NOT-SAME-SIGNATURE-DEPOSIT-A-LIST-TOO-LARGE-ADDR (rewrite)
  (implies (and (definedp (area-name addr) data-seg2)
		(lr-proper-p-areasp data-seg2)		
		(not (lessp (offset addr)
			    (length (value (area-name addr) data-seg1)))))
	   (equal (same-signature data-seg1
				  (deposit-a-list list addr data-seg2))
		  (if (listp list)
		      f
		      (same-signature data-seg1 data-seg2))))
  ((enable deposit-a-list)
   (induct (deposit-a-list list addr data-seg2))))

(prove-lemma SAME-SIGNATURE-DEPOSIT-A-LIST (rewrite)
  (implies (and (adpp (untag addr) data-seg2)
		(lr-proper-p-areasp data-seg2)
		(same-signature data-seg1 data-seg2))
	   (equal (same-signature data-seg1
				  (deposit-a-list list addr data-seg2))
		  (lessp (plus (offset addr) (sub1 (length list)))
			 (length (cdr (assoc (area-name addr)
					     data-seg1))))))
  ((enable deposit-a-list
	   adpp-untag-definedp-area-name
	   adpp-untag-lessp-offset
	   adpp-untag-numberp-offset
	   definedp-listp-cdr-assoc-lr-proper-p-areasp
	   same-signature-implies-equal-lengths)
   (induct (deposit-a-list list addr data-seg2))))

(disable not-same-signature-deposit-too-large-addr)
(disable not-same-signature-deposit-a-list-too-large-addr)

(prove-lemma DEPOSIT-GOOD-NODE-PRESERVES-LR-PROPER-FREE-LISTP (rewrite)
  (implies (and (lr-proper-free-listp data-seg)
		(lr-proper-p-areasp data-seg)
		(adpp (untag (lr-max-node data-seg)) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg))
		(lessp (offset (fetch (lr-fp-addr) data-seg))
		       (sub1 (sub1 (sub1 (length (cdr (assoc (lr-heap-name)
							     data-seg)))))))
		(equal (type tag) 'nat)
		(equal (type ref-count) 'nat)
		(numberp (untag ref-count)))
	   (lr-proper-free-listp
	    (deposit (fetch (add-addr (fetch (identity (lr-fp-addr))
					     data-seg)
				      (identity (lr-ref-count-offset)))
			    data-seg)
		     (identity (lr-fp-addr))
		     (deposit-a-list (list tag ref-count x y)
				     (fetch (identity (lr-fp-addr))
					    data-seg)
				     data-seg))))
  ((enable lr-proper-free-listp
	   adpp-deposit-other-area adpp-deposit-anything-at-all
	   definedp-listp-cdr-assoc-lr-proper-p-areasp
	   deposit-ref-count-move-inward-2
	   lr-max-node-same-signature
	   lr-check-free-nodes-delete-deposit
	   lr-node-listp-delete lr-node-listp-deposit-anything-at-all)
   (expand (lr-check-free-nodes (fetch (identity (lr-fp-addr)) data-seg)
				(lr-free-list-nodes (lr-max-node data-seg)
						    data-seg)
				data-seg
				(lr-max-node data-seg)))
   (disable-theory addition)
   (disable definedp delete length lr-free-list-nodes
	    lr-check-free-nodes lr-proper-p-areasp
	    deposit-ref-count-move-outward
	    length-deposit
	    member-non-list
	    lr-proper-heapp-opener-1
	    lr-proper-heapp-opener-4)))

(prove-lemma P-RUN-SUBR-PRESERVES-LR-PROPER-FREE-LISTP (rewrite)
  (implies (and (good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(lr-programs-properp new-l table)
		(listp (lr-expr l))
		(proper-p-statep (lr->p new-l))
		(lr-proper-free-listp (p-data-segment new-l))
		(adpp (untag (lr-max-node (p-data-segment new-l)))
		      (p-data-segment new-l))
		(lr-boundary-nodep (lr-max-node (p-data-segment new-l)))
		(equal (p-psw new-l) 'run)
		(equal (p-psw (p-run-subr (car (lr-expr l))
					  (p-set-pc (lr->p new-l)
						    (lr-return-pc l))))
		       'run)
		(equal (p-prog-segment l) (p-prog-segment new-l))
		(equal (area-name (p-pc l)) (area-name (p-pc new-l))))
	   (lr-proper-free-listp
	    (p-data-segment (p-run-subr (car (lr-expr l))
					(p-set-pc (lr->p new-l)
						  (lr-return-pc l))))))
  ((enable p-run-subr p-current-program)
   (use (same-signature-p-run-subr (subr 'cons)
				   (p (p-set-pc (lr->p new-l)
						(lr-return-pc l)))
				   (data-seg (p-data-segment new-l))))
   (disable length lr-p-c-size lr-p-c-size-list
	    deposit-a-list-cons-opener
	    program-body-assoc-comp-programs)))

(disable same-signature-deposit)

(prove-lemma LR-APPLY-SUBR-PRESERVES-LR-PROPER-FREE-LISTP (rewrite)
  (let ((new-l (lr-eval 'list (lr-set-pos l pos) c)))
    (implies (and (good-posp1 (offset (p-pc l))
			      (program-body (p-current-program l)))
		  (lr-programs-properp l table)
		  (listp (lr-expr l))
		  (subrp (car (lr-expr l)))
		  (not (equal (car (lr-expr l)) 'if))
		  (proper-p-statep (lr->p new-l))
		  (lr-proper-free-listp (p-data-segment new-l))
		  (adpp (untag (lr-max-node (p-data-segment new-l)))
			(p-data-segment new-l))
		  (lr-boundary-nodep (lr-max-node (p-data-segment new-l)))
		  (equal (p-psw new-l) 'run)
		  (equal (p-psw (lr-apply-subr l new-l)) 'run))
	     (lr-proper-free-listp (p-data-segment (lr-apply-subr l
								  new-l)))))
  ((enable lr-apply-subr)))

(prove-lemma LR-EVAL-PRESERVES-PROPER-P-STATEP-LR->P-REWRITE (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag l c)) 'run))
	   (proper-p-statep (lr->p (lr-eval flag l c))))
  ((use (lr-eval-preserves-proper-p-statep-lr->p (l l) (flag flag) (c c)))
   (disable lr-eval)))

(prove-lemma LR-EVAL-PRESERVES-CDR-P-CTRL-STK (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag l c)) 'run))
	   (equal (cdr (p-ctrl-stk (lr-eval flag l c)))
		  (cdr (p-ctrl-stk l))))
  ((use (lr-eval-preserves-proper-p-statep-lr->p (l l) (flag flag) (c c)))
   (disable lr-compile-body lr-compile-programs lr-eval)))

(prove-lemma LR-EVAL-PRESERVES-STRIP-CARS-BINDINGS-CAR-P-CTRL-STK (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag l c)) 'run))
	   (equal (strip-cars (bindings (car (p-ctrl-stk (lr-eval flag
								  l
								  c)))))
		  (strip-cars (bindings (car (p-ctrl-stk l))))))
  ((use (lr-eval-preserves-proper-p-statep-lr->p (l l) (flag flag) (c c)))
   (disable lr-compile-body lr-compile-programs lr-eval)))

(prove-lemma LR-EVAL-PRESERVES-LR-MAX-NODE (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag l c)) 'run))
	   (equal (lr-max-node (p-data-segment (lr-eval flag l c)))
		  (lr-max-node (p-data-segment l))))
  ((enable lr-max-node-same-signature)
   (use (lr-eval-preserves-proper-p-statep-lr->p (l l) (flag flag) (c c)))
   (disable lr-compile-body lr-compile-programs lr-eval)))

(prove-lemma LR-EVAL-PRESERVES-ADPP (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag l c)) 'run))
	   (equal (adpp adp (p-data-segment (lr-eval flag l c)))
		  (adpp adp (p-data-segment l))))
  ((use (lr-eval-preserves-proper-p-statep-lr->p (l l) (flag flag) (c c))
	(adpp-same-signature (data-seg2 (p-data-segment l))
			     (data-seg1 (p-data-segment (lr-eval flag l c)))
			     (adp adp)))
   (disable lr-compile-body lr-compile-programs lr-eval)))

(prove-lemma LR-EVAL-PRESERVES-LENGTH-ASSOC-DATA-SEGMENT (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag l c)) 'run))
	   (equal (length (cdr (assoc name
				      (p-data-segment (lr-eval flag l c)))))
		  (length (cdr (assoc name (p-data-segment l))))))
  ((enable same-signature-implies-equal-lengths)
   (use (lr-eval-preserves-proper-p-statep-lr->p (l l) (flag flag) (c c)))
   (disable lr-compile-body lr-compile-programs lr-eval)))

(prove-lemma LR-EVAL-PRESERVES-PROPER-P-STATEP-LR->P-LR-SET-POS (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag pos (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag (lr-set-pos l pos) c)) 'run))
	   (proper-p-statep (lr->p (lr-eval flag (lr-set-pos l pos) c))))
  ((use (lr-eval-preserves-proper-p-statep-lr->p
	 (l (lr-set-pos l pos)) (flag flag) (c c) (table table)))
   (disable lr-eval)))

(prove-lemma LR-EVAL-PRESERVES-STRIP-CARS-BINDINGS-CAR-P-CTRL-STK-LR-SET-POS
    (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp1 pos (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval t (lr-set-pos l pos) c)) 'run))
	   (equal (strip-cars (bindings (car (p-ctrl-stk
					      (lr-eval t
						       (lr-set-pos l pos)
						       c)))))
		  (strip-cars (bindings (car (p-ctrl-stk l))))))
  ((use (lr-eval-preserves-proper-p-statep-lr->p
	 (l (lr-set-pos l pos)) (flag t) (table table) (c c)))
   (disable lr-compile-body lr-compile-programs lr-eval)))

(prove-lemma LR-EVAL-PRESERVES-CDR-P-CTRL-STK-LR-SET-POS (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp1 pos (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval t (lr-set-pos l pos) c)) 'run))
	   (equal (cdr (p-ctrl-stk (lr-eval t (lr-set-pos l pos) c)))
		  (cdr (p-ctrl-stk l))))
  ((use (lr-eval-preserves-proper-p-statep-lr->p
	 (l (lr-set-pos l pos)) (flag t) (table table) (c c)))
   (disable lr-compile-body lr-compile-programs lr-eval)))

(prove-lemma LR-EVAL-PRESERVES-ADPP-LR-SET-POS (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag pos (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag (lr-set-pos l pos) c)) 'run))
	   (equal (adpp adp (p-data-segment (lr-eval flag
						     (lr-set-pos l pos)
						     c)))
		  (adpp adp (p-data-segment l))))
  ((use (lr-eval-preserves-adpp
	 (l (lr-set-pos l pos)) (flag flag) (table table)  (c c)))
   (disable lr-compile-body lr-compile-programs lr-eval)))

(prove-lemma LR-EVAL-PRESERVES-LR-MAX-NODE-LR-SET-POS (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag pos (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag (lr-set-pos l pos) c)) 'run))
	   (equal (lr-max-node (p-data-segment (lr-eval flag
							(lr-set-pos l pos)
							c)))
		  (lr-max-node (p-data-segment l))))
  ((use (lr-eval-preserves-lr-max-node
	 (l (lr-set-pos l pos)) (flag flag) (table table) (c c)))
   (disable lr-compile-body lr-compile-programs lr-eval
	    lr-eval-preserves-lr-max-node)))

(prove-lemma LR-EVAL-PRESERVES-LR-PROPER-FREE-LISTP (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag l c)) 'run)
		(adpp (untag (lr-max-node (p-data-segment l)))
		      (p-data-segment l))
		(lr-boundary-nodep (lr-max-node (p-data-segment l)))
		(lr-proper-free-listp (p-data-segment l)))
	   (lr-proper-free-listp (p-data-segment (lr-eval flag l c))))
  ((induct (lr-eval flag l c))
   (enable lr-eval-if-p-psw-1
	   transitivity-of-same-signature)
   (expand (lr-eval flag l c) (lr-eval 'list l c) (lr-eval flag l 0))
   (disable definedp lr-eval)))

(prove-lemma LR-APPLY-SUBR-PRESERVES-LR-VALP (rewrite)
  (let ((new-l (lr-eval 'list (lr-set-pos l pos) c)))
    (implies (and (good-posp1 (offset (p-pc l))
			      (program-body (p-current-program l)))
		  (lr-programs-properp l table)
		  (listp (lr-expr l))
		  (subrp (car (lr-expr l)))
		  (not (equal (car (lr-expr l)) 'if))
		  (proper-p-statep (lr->p new-l))
		  (lr-proper-free-listp (p-data-segment new-l))
		  (adpp (untag (lr-max-node (p-data-segment new-l)))
			(p-data-segment new-l))
		  (lr-boundary-nodep (lr-max-node (p-data-segment new-l)))
		  (equal (p-psw new-l) 'run)
		  (equal (p-psw (lr-apply-subr l new-l)) 'run)
		  (lr-valp value addr (p-data-segment new-l)))
	     (lr-valp value addr (p-data-segment (lr-apply-subr l new-l)))))
  ((enable lr-apply-subr)))

(prove-lemma LR-EVAL-PRESERVES-LR-PROPER-FREE-LISTP-LR-SET-POS (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag pos (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag (lr-set-pos l pos) c)) 'run)
		(adpp (untag (lr-max-node (p-data-segment l)))
		      (p-data-segment l))
		(lr-boundary-nodep (lr-max-node (p-data-segment l)))
		(lr-proper-free-listp (p-data-segment l)))
	   (lr-proper-free-listp (p-data-segment (lr-eval flag
							  (lr-set-pos l pos)
							  c))))
  ((use (lr-eval-preserves-lr-proper-free-listp
	 (flag flag) (l (lr-set-pos l pos)) (table table) (c c)))
   (disable definedp lr-eval)))

(prove-lemma LR-EVAL-PRESERVES-LR-VALP (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag l c)) 'run)
		(lr-proper-free-listp (p-data-segment l))
		(adpp (untag (lr-max-node (p-data-segment l)))
		      (p-data-segment l))
		(lr-boundary-nodep (lr-max-node (p-data-segment l)))
		(lr-valp value addr (p-data-segment l)))
	   (lr-valp value addr (p-data-segment (lr-eval flag l c))))
  ((induct (lr-eval flag l c))
   (enable lr-eval-if-p-psw-1
	   transitivity-of-same-signature)
   (expand (lr-eval flag l c) (lr-eval 'list l c) (lr-eval flag l 0))
   (disable definedp lr-eval)))

(prove-lemma LR-CHECK-F-ADDRP-DEPOSIT-ANYTHING-ANYWHERE (rewrite)
  (equal (lr-check-f-addrp addr (deposit anything anywhere data-seg))
	 (lr-check-f-addrp addr data-seg))
  ((enable lr-check-f-addrp)))

(prove-lemma LR-CHECK-UNDEF-ADDRP-DEPOSIT-ANYTHING-ANYWHERE (rewrite)
  (equal (lr-check-undef-addrp addr (deposit anything anywhere data-seg))
	 (lr-check-undef-addrp addr data-seg))
  ((enable lr-check-undef-addrp)))

(prove-lemma LR-CHECK-LISTP-ADDRP-DEPOSIT-FREE-PTR-0 (rewrite)
  (equal (lr-check-listp-addrp addr
			       (deposit any
					(identity (lr-fp-addr))
					data-seg))
	 (lr-check-listp-addrp addr data-seg))
  ((enable area-name lr-check-listp-addrp
	   adpp-deposit-other-area)))

(prove-lemma LR-CHECK-NUMBERP-ADDRP-DEPOSIT-FREE-PTR-0 (rewrite)
  (equal (lr-check-numberp-addrp addr
				 (deposit any
					  (identity (lr-fp-addr))
					  data-seg))
	 (lr-check-numberp-addrp addr data-seg))
  ((enable area-name lr-check-numberp-addrp
	   adpp-deposit-other-area)))

(prove-lemma LR-PROPER-HEAPP-NODEP-DEPOSIT-FREE-PTR-0 (rewrite)
  (equal (lr-proper-heapp-nodep addr
				(deposit any
					 (identity (lr-fp-addr))
					 data-seg))
	 (lr-proper-heapp-nodep addr data-seg))
  ((enable area-name lr-proper-heapp-nodep
	   adpp-deposit-other-area
	   adpp-untag-numberp-offset)))

(prove-lemma LR-PROPER-HEAPP2-DEPOSIT-FREE-PTR-0 (rewrite)
  (equal (lr-proper-heapp2 addr
			   (deposit any (identity (lr-fp-addr)) data-seg))
	 (lr-proper-heapp2 addr data-seg))
  ((disable-theory addition)))

(prove-lemma LR-BOUNDARY-OFFSETP-EQUAL-PLUS-FACT-ZERO (rewrite)
  (implies (and (lr-boundary-offsetp offset1)
		(lr-boundary-offsetp offset2)
		(lessp n (lr-node-size))
		(numberp offset1)
		(numberp offset2))
	   (equal (equal (plus n offset1) offset2)
		  (and (zerop n) (equal offset1 offset2))))
  ((disable-theory addition quotients)
   (use (equal-plus-remainder-0-fact (offset1 offset1)
				     (offset2 offset2)
				     (max (lr-node-size))
				     (n n)
				     (m 0)))))

(prove-lemma FETCH-ADD-ADDR-DEPOSIT-A-LIST-NODE (rewrite)
  (implies (and (adpp (untag max-addr) data-seg)
		(lr-boundary-nodep max-addr)
		(adpp (untag addr) data-seg)
		(lr-boundary-nodep addr)
		(equal (area-name addr) (area-name max-addr))
		(lessp n (lr-node-size)))
	   (equal (fetch (add-addr max-addr n)
			 (deposit-a-list (list x0 x1 x2 x3) addr data-seg))
		  (if (equal (offset addr) (offset max-addr))
		      (get n (list x0 x1 x2 x3))
		      (fetch (add-addr max-addr n) data-seg))))
  ((enable lr-boundary-nodep
	   adpp-untag-numberp-offset
	   adpp-untag-definedp-area-name
	   commutativity-of-plus)
   (disable lr-boundary-offsetp plus
	    plus-add1-arg1 plus-add1-arg2)))

(prove-lemma FETCH-DEPOSIT-A-LIST-NODE (rewrite)
  (implies (and (adpp (untag max-addr) data-seg)
		(lr-boundary-nodep max-addr)
		(adpp (untag addr) data-seg)
		(lr-boundary-nodep addr)
		(equal (area-name addr) (area-name max-addr)))
	   (equal (fetch max-addr
			 (deposit-a-list (list x0 x1 x2 x3) addr data-seg))
		  (if (equal (offset addr) (offset max-addr))
		      x0
		      (fetch max-addr data-seg))))
  ((enable lr-boundary-nodep
	   adpp-untag-numberp-offset
	   adpp-untag-definedp-area-name
	   commutativity-of-plus)
   (disable plus)
   (disable-theory addition)))

(disable lr-boundary-offsetp-equal-plus-fact-zero)

(prove-lemma LR-CHECK-F-ADDRP-DEPOSIT-A-LIST (rewrite)
  (equal (lr-check-f-addrp addr (deposit-a-list list anywhere data-seg))
	 (lr-check-f-addrp addr data-seg))
  ((enable lr-check-f-addrp)))

(prove-lemma LR-CHECK-UNDEF-ADDRP-DEPOSIT-A-LIST (rewrite)
  (equal (lr-check-undef-addrp addr (deposit-a-list list anywhere data-seg))
	 (lr-check-undef-addrp addr data-seg))
  ((enable lr-check-undef-addrp)))

(prove-lemma LR-CHECK-NUMBERP-ADDRP-DEPOSIT-A-LIST-CONS (rewrite)
  (implies (and (not (equal (offset addr) (offset max-addr)))
		(equal (type max-addr) 'addr)
		(equal (cddr max-addr) nil)
		(listp max-addr)
		(adpp (untag max-addr) data-seg)
		(lr-boundary-nodep max-addr)
		(equal (area-name max-addr) (lr-heap-name))
		(equal (type addr) 'addr)
		(equal (cddr addr) nil)
		(listp addr)
		(adpp (untag addr) data-seg)
		(lr-boundary-nodep addr)
		(equal (area-name addr) (lr-heap-name))
		(lr-check-numberp-addrp max-addr data-seg)
		(equal (type tag) 'nat)
		(numberp (untag tag)))
         (lr-check-numberp-addrp max-addr
                                 (deposit-a-list (list x0 tag x2 x3)
                                                 addr
						 data-seg)))
  ((enable lr-check-numberp-addrp
	   adpp-deposit-anything-at-all
	   adpp-untag-listp
	   adpp-untag-numberp-offset
	   commutativity-of-plus)
   (disable-theory addition)
   (disable plus)))

(prove-lemma LR-CHECK-LISTP-ADDRP-DEPOSIT-A-LIST-CONS (rewrite)
  (implies (and (lr-good-pointerp good-pointer1 data-seg)
		(lr-good-pointerp good-pointer2 data-seg)
		(adpp (untag addr) data-seg)
		(lr-boundary-nodep addr)
		(adpp (untag max-addr) data-seg)
		(lr-boundary-nodep max-addr)
		(equal (area-name addr) (lr-heap-name))
		(equal (area-name max-addr) (lr-heap-name))
		(equal (type tag) 'nat)
		(numberp (untag tag))
		(equal (offset addr) (offset max-addr)))
	   (lr-check-listp-addrp max-addr
				 (deposit-a-list
				  (list (identity (tag 'nat (lr-cons-tag)))
					tag
					good-pointer1
					good-pointer2)
				  addr
				  data-seg)))
  ((enable lr-check-listp-addrp
	   adpp-deposit-anything-at-all
	   adpp-untag-numberp-offset
	   commutativity-of-plus
	   difference-plus-cancellation)
   (use (adpp-untag-definedp-area-name (addr addr) (data-seg data-seg)))
   (disable-theory addition)
   (disable plus
	    deposit-a-list-cons-opener)))

(prove-lemma LR-CHECK-LISTP-ADDRP-DEPOSIT-A-LIST-OTHER-PLACE (rewrite)
  (implies (and (adpp (untag addr) data-seg)
		(lr-boundary-nodep addr)
		(adpp (untag max-addr) data-seg)
		(lr-boundary-nodep max-addr)
		(equal (area-name addr) (lr-heap-name))
		(equal (area-name max-addr) (lr-heap-name))
		(lr-check-listp-addrp max-addr data-seg)
		(not (equal (offset addr) (offset max-addr)))
		(equal (type ref-count) 'nat))
	   (lr-check-listp-addrp max-addr
				 (deposit-a-list (list x0 ref-count x2 x3)
						 addr
						 data-seg)))
  ((enable lr-check-listp-addrp
	   adpp-deposit-anything-at-all
	   adpp-untag-numberp-offset
	   commutativity-of-plus)
   (disable-theory addition)
   (disable plus
	    deposit-a-list-cons-opener)))

(prove-lemma LR-PROPER-HEAPP-NODEP-DEPOSIT-A-LIST-CONS (rewrite)
  (implies (and (lr-nodep max-addr data-seg)
		(lr-nodep addr data-seg)
		(lr-proper-heapp-nodep max-addr data-seg)
		(not (equal (type (fetch (add-addr addr
						   (lr-ref-count-offset))
					 data-seg))
			    'nat))
		(lr-good-pointerp good-pointer1 data-seg)
		(lr-good-pointerp good-pointer2 data-seg)
		(equal (type tag) 'nat)
		(numberp (untag tag)))
	   (lr-proper-heapp-nodep max-addr
				  (deposit-a-list
				   (list (identity (tag 'nat
							(lr-cons-tag)))
					 tag
					 good-pointer1
					 good-pointer2)
				   addr
				   data-seg)))
  ((disable-theory addition)
   (enable lr-proper-heapp-nodep
	   adpp-untag-listp
	   adpp-untag-numberp-offset
	   adpp-untag-definedp-area-name
	   commutativity-of-plus
	   difference-plus-cancellation difference-x-x)
   (use (adpp-area-name-offset-same (addr1 addr) (addr2 max-addr)))
   (disable plus
	    deposit-a-list-cons-opener
	    lr-good-pointerp-opener)))

(PROVE-LEMMA LR-PROPER-HEAPP2-DEPOSIT-A-LIST-CONS (rewrite)
  (implies (and (lr-nodep max-addr data-seg)
		(lr-nodep addr data-seg)
		(lr-proper-heapp2 max-addr data-seg)
		(not (equal (type (fetch (add-addr addr
						   (lr-ref-count-offset))
					 data-seg))
			    'nat))
		(lr-good-pointerp good-pointer1 data-seg)
		(lr-good-pointerp good-pointer2 data-seg)
		(equal (type tag) 'nat)
		(numberp (untag tag)))
	   (lr-proper-heapp2 max-addr
			     (deposit-a-list
			      (list (identity (tag 'nat (lr-cons-tag)))
				    tag
				    good-pointer1
				    good-pointer2)
			      addr
			      data-seg)))
  ((disable deposit-a-list-cons-opener)
   (disable-theory addition)
   (induct (lr-proper-heapp2 max-addr data-seg))))

(prove-lemma NOT-PSW-RUN-LR-EVAL (rewrite)
  (implies (not (equal (p-psw l) 'run))
	   (equal (lr-eval flag l c) l)))

(prove-lemma PROGRAM-BODY-ASSOC-LR-COMPILE-PROGRAMS (rewrite)
  (equal (program-body (assoc name
			      (lr-compile-programs progs table)))
	 (lr-compile-body t
			  (s-body (assoc name progs))
			  (lr-make-temp-name-alist
			   (s-temp-list (assoc name progs))
			   (s-formals (assoc name progs)))
			  table))
  ((enable program-body)
   (disable lr-make-temp-name-alist)))

(prove-lemma LISTP-LR-COMPILE-BODY (rewrite)
  (equal (listp (lr-compile-body flag body temp-name-alist table))
	 (listp body)))

(prove-lemma CAR-LR-COMPILE-BODY (rewrite)
  (implies (not (equal flag 'list))
	   (equal (car (lr-compile-body flag body temp-name-alist table))
		  (car body))))

(prove-lemma GOOD-POSP1-EXPAND-LIST-TEMPS (rewrite)
  (implies (and (or (equal temp (s-temp-eval))
		    (equal temp (s-temp-test)))
		(listp pos))
	   (equal (good-posp1 pos (list temp body name))
		  (and (equal (car pos) 1)
		       (good-posp1 (cdr pos) body))))
  ((enable good-posp1)))

(prove-lemma LENGTH-LR-COMPILE-BODY-LIST (rewrite)
  (equal (length (lr-compile-body 'list body temp-name-alist table))
	 (length body))
  ((induct (length body))))

(prove-lemma GET-LR-COMPILE-BODY-LIST (rewrite)
  (equal (get n (lr-compile-body 'list body temp-name-alist table))
	 (lr-compile-body t (get n body) temp-name-alist table))
  ((enable get
	   get-anything-nil)))

(prove-lemma GET-LR-COMPILE-BODY (rewrite)
  (implies (and (listp body)
		(not (equal (car body) (s-temp-fetch)))
		(not (equal (car body) (s-temp-eval)))
		(not (equal (car body) (s-temp-test)))
		(not (equal (car body) 'quote))
		(not (zerop n)))
	   (equal (get n (lr-compile-body t body temp-name-alist table))
		  (lr-compile-body t (get n body) temp-name-alist table)))
  ((enable get-cons)))

(prove-lemma LENGTH-LR-COMPILE-BODY-T (rewrite)
  (implies (and (listp body)
		(not (equal (car body) (s-temp-fetch)))
		(not (equal (car body) (s-temp-eval)))
		(not (equal (car body) (s-temp-test)))
		(not (equal (car body) 'quote)))
	   (equal (length (lr-compile-body t body temp-name-alist table))
		  (length body))))

(prove-lemma GOOD-POSP1-LR-COMPILE-BODY (rewrite)
  (equal (good-posp1 pos (lr-compile-body t body temp-name-alist table))
	 (good-posp1 pos body))
  ((enable good-posp1)))

(prove-lemma CUR-EXPR-LR-COMPILE-BODY-T (rewrite)
  (implies (good-posp1 pos body)
	   (equal (cur-expr pos
			    (lr-compile-body t body temp-name-alist table))
		  (lr-compile-body t
				   (cur-expr pos body)
				   temp-name-alist
				   table)))
  ((enable good-posp1)))

(prove-lemma LR-CHECK-RESULT1-SINGLETON-LIST-OPENER (rewrite)
  (equal (lr-check-result1 (list x) temp-stk data-seg)
	 (lr-valp x (car temp-stk) data-seg)))

(prove-lemma PROPER-P-TEMP-STKP-PLISTP-P-TEMP-STK ()
  (implies (proper-p-temp-stkp temp-stk p)
	   (plistp temp-stk)))

(prove-lemma PROPER-P-STATEP-LR->P-PLISTP-P-TEMP-STK (rewrite)
  (implies (proper-p-statep (lr->p l))
	   (plistp (p-temp-stk l)))
  ((use (proper-p-temp-stkp-plistp-p-temp-stk (temp-stk (p-temp-stk l))
					      (p (lr->p l))))
   (enable proper-p-statep)))

(prove-lemma PROPER-P-STATEP-LR->P-NOT-0-P-TEMP-STK (rewrite)
  (implies (proper-p-statep (lr->p l))
	   (not (equal (p-temp-stk l) 0)))
  ((use (proper-p-statep-lr->p-plistp-p-temp-stk (p (lr->p l))))))

(prove-lemma PLISTP-LASTCDR-NIL (rewrite)
  (implies (plistp list)
	   (equal (lastcdr list) nil)))

(prove-lemma LR-EVAL-PRESERVES-LR-VALP-LR-SET-EXPR (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(proper-p-statep (lr->p (lr-set-expr l1 l pos)))
		(good-posp flag pos (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag (lr-set-expr l1 l pos) c)) 'run)
		(lr-proper-free-listp (p-data-segment l))
		(lr-proper-free-listp (p-data-segment l1))
		(adpp (untag (lr-max-node (p-data-segment l)))
		      (p-data-segment l))
		(lr-boundary-nodep (lr-max-node (p-data-segment l)))
		(adpp (untag (lr-max-node (p-data-segment l1)))
		      (p-data-segment l1))
		(lr-boundary-nodep (lr-max-node (p-data-segment l1)))
		(lr-valp value addr (p-data-segment l1))
		(equal (length (cdr (assoc (lr-heap-name)
					   (p-data-segment l1))))
		       (length (cdr (assoc (lr-heap-name)
					   (p-data-segment l))))))
	   (lr-valp value
		    addr
		    (p-data-segment (lr-eval flag
					     (lr-set-expr l1 l pos)
					     c))))
  ((use (lr-eval-preserves-lr-valp
	 (l (lr-set-expr l1 l pos))
	 (value value) (addr addr) (flag flag) (table table) (c c)))
   (disable definedp lr-eval lr-valp)))

(prove-lemma LR-EVAL-PRESERVES-PROPER-P-STATEP-LR->P-LR-SET-EXPR (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag pos (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag (lr-set-expr l1 l pos) c))
		       'run)
		(lr-programs-properp l1 table)
		(proper-p-statep (lr->p l1))
		(equal (cdr (p-ctrl-stk l1))
		       (cdr (p-ctrl-stk l)))
		(equal (strip-cars (bindings (car (p-ctrl-stk l1))))
		       (strip-cars (bindings (car (p-ctrl-stk l)))))
		(equal (p-prog-segment l1)
		       (p-prog-segment l))
		(equal (p-word-size l1)
		       (p-word-size l))
		(equal (p-max-ctrl-stk-size l1)
		       (p-max-ctrl-stk-size l))
		(equal (p-max-temp-stk-size l1)
		       (p-max-temp-stk-size l)))
	   (proper-p-statep (lr->p (lr-eval flag
					    (lr-set-expr l1 l pos)
					    c))))
  ((use (lr-eval-preserves-proper-p-statep-lr->p-rewrite
	 (l (lr-set-expr l1 l pos)) (flag flag) (table table) (c c)))
   (disable lr-eval)))

(prove-lemma LR-CHECK-RESULT-FLAG-LIST-CONS-VALUE (rewrite)
  (let ((l2 (lr-eval 'list (lr-set-expr (lr-eval t l c) l (nx pos)) c)))
    (implies (and (good-posp 'list pos (program-body (p-current-program l)))
		  (lr-programs-properp l table)
		  (proper-p-statep (lr->p l))
		  (listp (lr-expr-list l))
		  (listp (offset (p-pc l)))
		  (lr-proper-heapp (p-data-segment l))
		  (lr-check-result t
				   value1
				   (p-temp-stk (lr-eval t l c))
				   (p-data-segment (lr-eval t l c))
				   (p-temp-stk l))
		  (lr-check-result 'list
				   value2
				   (p-temp-stk l2)
				   (p-data-segment l2)
				   (p-temp-stk (lr-eval t l c)))
		  (equal (p-psw l2) 'run)
		  (equal pos (offset (p-pc l)))
		  (equal temp-stk (p-temp-stk l)))
	     (lr-check-result 'list
			      (cons value1 value2)
			      (p-temp-stk l2)
			      (p-data-segment l2)
			      temp-stk)))
  ((enable lr-check-result
	   restn-cdr
	   lr-minimum-heapp-opener-3)
   (use (restn-cdr (n (length value2))
		   (x (p-temp-stk (lr-eval 'list
					   (lr-set-expr (lr-eval t l c)
							l
							(nx pos))
					   c)))))
   (disable lr-check-result1 lr-eval)))

(prove-lemma LR-CHECK-RESULT-NIL (rewrite)
  (implies (lr-proper-heapp data-seg)
	   (lr-check-result 'list nil temp-stk data-seg temp-stk))
  ((enable lr-check-result)))

(prove-lemma LITATOM-LR-COMPILE-BODY (rewrite)
  (equal (litatom (lr-compile-body t body temp-name-alist table))
	 (litatom body)))

(prove-lemma LR-PARAMS-LR-PUSH-TSTK (rewrite)
  (equal (lr-params frame (lr-push-tstk l anything)) (lr-params frame l))
  ((enable lr-params)))

(prove-lemma LR-TEMPS-LR-PUSH-TSTK (rewrite)
  (equal (lr-temps frame (lr-push-tstk l anything)) (lr-temps frame l))
  ((enable lr-temps)))

(prove-lemma PROGRAM-BODY-P-CURRENT-PROGRAM-S->LR1 (rewrite)
  (equal (program-body (p-current-program (s->lr1 s l table)))
	 (lr-compile-body t
			  (s-body (s-prog s))
			  (lr-make-temp-name-alist (s-temp-list (s-prog s))
						   (s-formals (s-prog s)))
			  table))
  ((disable lr-make-temp-name-alist)
   (enable p-current-program s-prog)))

(prove-lemma NAME-CAR-LR-COMPILE-PROGRAMS-PROGS (rewrite)
  (equal (name (car (lr-compile-programs (s-progs s) table)))
	 (caar (s-progs s)))
  ((disable lr-compile-body lr-make-temp-name-alist)
   (expand (lr-compile-programs (s-progs s) table))))

(prove-lemma CAR-CAR-LR-COMPILE-PROGRAMS-PROGS (rewrite)
  (equal (caar (lr-compile-programs (s-progs s) table))
	 (caar (s-progs s)))
  ((disable lr-compile-body lr-make-temp-name-alist)
   (expand (lr-compile-programs (s-progs s) table))))

(prove-lemma S-GOOD-STATEP-PROGRAM-BODY-CAR-LR-COMPILE-PROGRAMS (rewrite)
  (implies (s-good-statep s c)
	   (equal (program-body (car (lr-compile-programs (s-progs s)
							  table)))
		  (lr-compile-body t
				   (s-body (car (s-progs s)))
				   (lr-make-temp-name-alist
				    (s-temp-list (car (s-progs s)))
				    (s-formals (car (s-progs s))))
				   table)))
  ((use (s-good-statep-backchainer-1 (s s) (c c)))
   (expand (lr-compile-programs (s-progs s) table))
   (disable lr-compile-body lr-make-temp-name-alist
	    s-good-statep-backchainer-1)))

(prove-lemma GOOD-POSP-LR-COMPILE-BODY (rewrite)
  (equal (good-posp flag
		    pos
		    (lr-compile-body t body temp-name-alist table))
	 (good-posp flag pos body))
  ((enable good-posp)
   (disable lr-compile-body)))

(prove-lemma STRIP-CARS-LR-COMPILE-PROGRAMS (rewrite)
  (equal (strip-cars (lr-compile-programs progs table)) (strip-cars progs))
  ((disable lr-compile-body)))

(prove-lemma LISTP-LR-EXPR-LIST-S->LR1 (rewrite)
  (implies (good-posp 'list (s-pos s) (s-body (s-prog s)))
	   (equal (listp (lr-expr-list (s->lr1 s l table)))
		  (listp (s-expr-list s))))
  ((enable good-posp lr-expr-list s-expr-list)
   (disable cur-expr lr-compile-programs lr-compile-body)))

(prove-lemma FORMAL-VARS-LR-COMPILE-PROGRAMS (rewrite)
  (equal (formal-vars (assoc name (lr-compile-programs progs
						       table)))
	 (s-formals (assoc name progs)))
  ((enable formal-vars)
   (disable lr-make-temp-name-alist)))

(prove-lemma FORMAL-VARS-P-CURRENT-PROGRAM-S->LR1 (rewrite)
  (equal (formal-vars (p-current-program (s->lr1 s l table)))
	 (s-formals (s-prog s)))
  ((enable p-current-program s-prog)
   (disable lr-make-temp-name-alist)))

(prove-lemma TEMP-VAR-DCLS-LR-COMPILE-PROGRAMS (rewrite)
  (implies (definedp name progs)
	   (equal (temp-var-dcls (assoc name
					(lr-compile-programs progs
							     table)))
		  (lr-make-temp-var-dcls
		   (lr-make-temp-name-alist (s-temp-list (assoc name progs))
					    (s-formals (assoc name
							      progs))))))
  ((enable temp-var-dcls)
   (disable lr-make-temp-name-alist)))

(prove-lemma TEMP-VAR-DCLS-ASSOC-P-CURRENT-PROGRAM-S->LR1 (rewrite)
  (implies (definedp (s-pname s) (s-progs s))
	   (equal (temp-var-dcls (p-current-program (s->lr1 s l table)))
		  (lr-make-temp-var-dcls
		   (lr-make-temp-name-alist (s-temp-list (s-prog s))
					    (s-formals (s-prog s))))))
 ((enable p-current-program s-prog)
  (disable lr-make-temp-name-alist)))

(prove-lemma LR-SET-EXPR-S->LR1-S-SET-EXPR (rewrite)
  (equal (s->lr1 (s-set-expr (s-eval t s c) s (nx (s-pos s)))
		 (lr-eval t (s->lr1 s l table) c)
		 table)
	 (lr-set-error (lr-set-expr (lr-eval t (s->lr1 s l table) c)
				    (s->lr1 s l table)
				    (nx (s-pos s)))
		       (s-err-flag (s-eval t s c))))
  ((enable lr-set-expr lr-set-error)
   (disable lr-eval s-eval)))

(prove-lemma P-CURRENT-PROGRAM-LR-SET-ERROR (rewrite)
  (equal (p-current-program (lr-set-error l err-flag))
	 (p-current-program l))
  ((enable p-current-program)))

(prove-lemma LR-SET-ERROR-LR-SET-ERROR (rewrite)
  (equal (lr-set-error (lr-set-error l err-flag1) err-flag2)
	 (lr-set-error l err-flag2))
  ((enable lr-set-error)))

(prove-lemma PROPER-P-STATEP-LR-SET-ERROR (rewrite)
  (equal (proper-p-statep (lr-set-error l err-flag))
	 (proper-p-statep l))
  ((enable proper-p-statep)
   (disable definedp exp p-ctrl-stk-size proper-p-alistp proper-p-ctrl-stkp
	    proper-p-data-segmentp proper-p-temp-stkp
	    proper-p-prog-segmentp)))

(prove-lemma LR-PARAMS-LR-SET-ERROR (rewrite)
  (equal (lr-params frame (lr-set-error l err-flag))
	 (lr-params frame l))
  ((enable lr-params)))

(prove-lemma LR-TEMPS-LR-SET-ERROR (rewrite)
  (equal (lr-temps frame (lr-set-error l err-flag))
	 (lr-temps frame l))
  ((enable lr-temps)))

(prove-lemma LR-S-SIMILAR-STATESP-LR-SET-ERROR (rewrite)
  (equal (lr-s-similar-statesp params temps (lr-set-error l err-flag) table)
	 (lr-s-similar-statesp params temps l table))
  ((enable lr-s-similar-statesp)
   (disable lr-s-similar-const-table lr-s-similar-params
	    lr-s-similar-temps)))

(prove-lemma LR-S-SIMILAR-STATESP-LR-SET-EXPR (rewrite)
  (implies (and (equal (area-name (p-pc l1)) (area-name (p-pc l2)))
		(equal (p-prog-segment l1) (p-prog-segment l2)))
	   (equal (lr-s-similar-statesp params
					temps
					(lr-set-expr l1 l2 pos)
					table)
		  (lr-s-similar-statesp params temps l1 table)))
  ((enable lr-s-similar-statesp)
   (disable lr-s-similar-const-table lr-s-similar-params
	    lr-s-similar-temps)))

(prove-lemma LR-EVAL-ZEROP-CLOCK (rewrite)
  (implies (and (zerop c)
		(not (equal flag 'list))
		(equal (p-psw l) 'run))
	   (equal (lr-eval flag l c) (lr-set-error l 'out-of-time))))

(prove-lemma LITATOM-LR-EXPR-S->LR1 (rewrite)
  (implies (and (good-posp1 (s-pos s) (s-body (s-prog s)))
		(litatom (s-expr s)))
	   (equal (lr-expr (s->lr1 s l table)) (s-expr s)))
  ((enable lr-expr s-expr)
   (disable cur-expr lr-compile-programs)))

(prove-lemma LR-EVAL-LITATOM-OPENER (rewrite)
  (implies (and (good-posp1 (s-pos s) (s-body (s-prog s)))
		(not (equal flag 'list))
		(not (zerop c))
		(litatom (s-expr s))
		(equal (s-err-flag s) 'run))
	   (equal (lr-eval flag (s->lr1 s l table) c)
		  (lr-push-tstk (s->lr1 s l table)
				(local-var-value (s-expr s)
						 (p-ctrl-stk l)))))
  ((expand (lr-eval flag (s->lr1 s l table) c))
   (enable good-posp1)
   (disable cur-expr lr-eval)))

(prove-lemma LR-S-SIMILAR-STATESP-LR-PUSH-TSTK-LITATOM (rewrite)
  (equal (lr-s-similar-statesp s-params
			       s-temps
			       (lr-push-tstk l value)
			       table)
	 (lr-s-similar-statesp s-params s-temps l table))
  ((enable lr-s-similar-statesp)
   (disable lr-s-similar-params lr-s-similar-temps
	    lr-s-similar-const-table)))

(prove-lemma LR-S-SIMILAR-PARAMS-ASSOC-DEFINEDP (rewrite)
  (implies (and (lr-s-similar-params s-params lr-params data-seg)
		(definedp name lr-params))
	   (lr-valp (cdr (assoc name s-params))
		    (cdr (assoc name lr-params))
		    data-seg)))

(prove-lemma PROPER-P-STATEP-LR->P-STRIP-CARS-BINDINGS-CTRL-STK (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(definedp (area-name (p-pc l)) (p-prog-segment l)))
	   (equal (strip-cars (bindings (car (p-ctrl-stk l))))
		  (append (formal-vars (assoc (area-name (p-pc l))
					      (p-prog-segment l)))
			  (strip-cars
			   (temp-var-dcls (assoc (area-name (p-pc l))
						 (p-prog-segment l)))))))
  ((enable proper-p-statep)
   (disable exp definedp p-ctrl-stk-size proper-p-alistp
	    proper-p-ctrl-stkp proper-p-data-segmentp proper-p-temp-stkp
	    proper-p-prog-segmentp)))

(defn INDUCT-HINT-11 (v y)
  (if (listp v)
      (if (listp y)
	  (induct-hint-11 (cdr v) (cdr y))
	  t)
      t))

(prove-lemma EQUAL-APPEND-SAME-LENGTH-FACT (rewrite)
  (implies (equal (length v) (length y))
	   (equal (equal (append (strip-cars v) w) (append y z))
		  (and (equal (strip-cars v) (plist y)) (equal w z))))
  ((induct (induct-hint-11 v y))))

(prove-lemma DEFINEDP-STRIP-CARS-APPEND-MEMBER-X ()
  (implies (equal (strip-cars x) (append y z))
	   (equal (member e y) (definedp e (firstn (length y) x))))
  ((enable strip-cars-append)
   (use (length-strip-cars (temp-vars x))
	(length-append (a y) (b z))
	(member-plist (x e) (y y))
	(member-strip-cars-definedp (x e) (y (firstn (length y) x))))
   (disable append-plist-lastcdr length-append length-strip-cars
	    member-plist)))

(prove-lemma PROPER-P-STATEP-LR->P-MEMBER-FORMALS-DEFINEDP-BINDINGS (rewrite)
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(definedp (s-pname s) (s-progs s))
		(member x (s-formals (assoc (s-pname s) (s-progs s)))))
	   (definedp x (firstn (length (s-formals (assoc (s-pname s)
							 (s-progs s))))
			       (bindings (car (p-ctrl-stk l))))))
  ((use (proper-p-statep-lr->p-strip-cars-bindings-ctrl-stk
	 (l (s->lr1 s l table)))
	(definedp-strip-cars-append-member-x
	  (x (bindings (car (p-ctrl-stk l))))
	  (y (formal-vars (assoc (area-name (p-pc (s->lr1 s l table)))
				 (p-prog-segment (s->lr1 s l table)))))
	  (z (strip-cars (temp-var-dcls
			  (assoc (area-name (p-pc (s->lr1 s l table)))
				 (p-prog-segment (s->lr1 s l table))))))
	  (e x)))
   (disable lr-compile-programs
	    proper-p-statep-lr->p-strip-cars-bindings-ctrl-stk)))

(prove-lemma LR-VALP-ADDR-0 (rewrite)
  (not (lr-valp addr 0 data-seg))
  ((expand (lr-valp addr 0 data-seg)
	   (lr-good-pointerp 0 data-seg)
	   (lr-nodep 0 data-seg))
   (disable lr-valp)))

(prove-lemma LR-VALP-CDR-ASSOC-FIRSTN-CDR-ASSOC (rewrite)
  (implies (lr-valp addr (cdr (assoc name (firstn n list))) data-seg)
	   (lr-valp addr (cdr (assoc name list)) data-seg))
  ((enable assoc-append-1
	   definedp-assoc-fact-1)
   (disable lr-valp)))

(prove-lemma LR-S-SIMILAR-STATESP-LR-S-SIMILAR-PARAMS-OPENER (rewrite)
  (implies (and (lr-s-similar-statesp s-params s-temps l table)
		(equal frame (car (p-ctrl-stk l)))
		(equal data-seg (p-data-segment l)))
	   (lr-s-similar-params s-params (lr-params frame l) data-seg))
  ((enable lr-s-similar-statesp)))

(prove-lemma LR-S-SIMILAR-STATESP-LR-S-SIMILAR-TEMPS-OPENER (rewrite)
  (implies (and (lr-s-similar-statesp s-params s-temps l table)
		(equal frame (car (p-ctrl-stk l)))
		(equal data-seg (p-data-segment l)))
           (lr-s-similar-temps s-temps (lr-temps frame l) data-seg))
  ((enable lr-s-similar-statesp)))

(prove-lemma STRIP-CARS-LR-MAKE-TEMP-VAR-DCLS (rewrite)
  (equal (strip-cars (lr-make-temp-var-dcls temp-alist))
	 (strip-cdrs temp-alist)))

(prove-lemma LR-CHECK-RESULT-LR-PUSH-TSTK (rewrite)
  (let ((value (cdr (assoc (s-expr s) (bindings (car (p-ctrl-stk l)))))))
    (implies (and (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (definedp (s-pname s) (s-progs s))
		  (equal (s-err-flag s) 'run)
		  (litatom (s-expr s))
		  (proper-p-statep (lr->p (s->lr1 s l table)))
		  (lr-proper-heapp (p-data-segment l))
		  (lr-programs-properp (s->lr1 s l table) table)
		  (equal (p-psw (lr-push-tstk (s->lr1 s l table)
					      value))
			 'run)
		  (lr-s-similar-statesp (s-params s)
					(s-temps s)
					(s->lr1 s l table)
					table))
	     (lr-check-result t
			      (cdr (assoc (s-expr s) (s-params s)))
			      (p-temp-stk (lr-push-tstk (s->lr1 s l table)
							value))
			      (p-data-segment l)
			      (p-temp-stk l))))
  ((enable lr-check-result lr-params lr-push-tstk s-prog)
   (use (lr-programs-properp-lr-proper-exprp-lr-expr (l (s->lr1 s l table))
						     (table table))
	(lr-s-similar-params-assoc-definedp
	 (s-params (s-params s))
	 (lr-params (lr-params (car (p-ctrl-stk l)) (s->lr1 s l table)))
	 (data-seg (p-data-segment l))
	 (name (s-expr s)))
	(lr-s-similar-statesp-lr-s-similar-params-opener
	 (s-params (s-params s))
	 (s-temps (s-temps s))
	 (frame (car (p-ctrl-stk l)))
	 (data-seg (p-data-segment l))
	 (l (s->lr1 s l table))
	 (table table)))
   (disable lr-compile-programs lr-make-temp-name-alist
	    lr-s-similar-params lr-valp
	    lr-s-similar-statesp-lr-s-similar-params-opener)))

(prove-lemma S->LR1-S-SET-POS-LR-SET-POS (rewrite)
  (equal (s->lr1 (s-set-pos s pos) l table)
	 (lr-set-pos (s->lr1 s l table) pos))
  ((enable s->lr1 lr-set-pos)))

(prove-lemma LR-PARAMS-LR-SET-POS (rewrite)
  (equal (lr-params frame (lr-set-pos l pos)) (lr-params frame l))
  ((enable lr-params)))

(prove-lemma LR-TEMPS-LR-SET-POS (rewrite)
  (equal (lr-temps frame (lr-set-pos l pos)) (lr-temps frame l))
  ((enable lr-temps)))

(prove-lemma LR-S-SIMILAR-STATESP-LR-S-SET-POS (rewrite)
  (equal (lr-s-similar-statesp s-params
			       s-temps
			       (lr-set-pos l pos)
			       table)
	 (lr-s-similar-statesp s-params s-temps l table))
  ((enable lr-s-similar-statesp)))

(prove-lemma LR-SET-EXPR-S->LR1-S-SET-EXPR-LR-POP-TSTK (rewrite)
  (equal (s->lr1 (s-set-expr (s-eval t (s-set-pos s pos) c)
			     s
			     (dv (s-pos s) n))
		 (lr-pop-tstk (lr-if-ok (lr-eval t
						 (lr-set-pos (s->lr1 s
								     l
								     table)
							     pos)
						 c)))
		 table)
	 (lr-set-error (lr-set-expr (lr-pop-tstk
				     (lr-if-ok
				      (lr-eval t
					       (lr-set-pos (s->lr1 s
								   l
								   table)
							   pos)
					       c)))
				    (s->lr1 s l table)
				    (dv (s-pos s) n))
		       (s-err-flag (s-eval t (s-set-pos s pos) c))))
  ((enable lr-set-expr lr-set-error)
   (disable lr-eval s-eval)))

(prove-lemma LR-S-SIMILAR-STATESP-LR-POP-TSTK (rewrite)
  (equal (lr-s-similar-statesp s-params s-temps (lr-pop-tstk l) table)
	 (lr-s-similar-statesp s-params s-temps l table))
  ((enable lr-s-similar-statesp)))

(prove-lemma LISTP-LR-EXPR-S->LR1 (rewrite)
  (implies (good-posp1 (s-pos s) (s-body (s-prog s)))
	   (equal (listp (lr-expr (s->lr1 s l table))) (listp (s-expr s))))
  ((enable lr-expr s-expr)
   (disable cur-expr lr-compile-programs lr-compile-body)))

(prove-lemma LITATOM-LR-EXPR-S->LR1-S-EXPR (rewrite)
  (implies (good-posp1 (s-pos s) (s-body (s-prog s)))
	   (equal (litatom (lr-expr (s->lr1 s l table)))
		  (litatom (s-expr s))))
  ((enable lr-expr s-expr)
   (disable cur-expr lr-compile-programs lr-compile-body)))

(prove-lemma CAR-LR-EXPR-S->LR1 (rewrite)
  (implies (good-posp1 (s-pos s) (s-body (s-prog s)))
	   (equal (car (lr-expr (s->lr1 s l table))) (car (s-expr s))))
  ((enable lr-expr s-expr)
   (disable cur-expr lr-compile-programs lr-compile-body)))

(prove-lemma EQUAL-P-PSW-LR-EVAL-RUN-LR-EVAL-LR-SET-ERROR (rewrite)
  (implies (equal (p-psw l) 'run)
	   (equal (lr-eval flag (lr-set-error l 'run) c)
		  (lr-eval flag l c)))
  ((enable lr-set-error)))

(prove-lemma LR-PROPER-HEAPP-LR-GOOD-POINTERP-LR-PROPER-HEAPP-NODEP ()
  (implies (and (lr-good-pointerp addr data-seg)
		(lr-proper-p-areasp data-seg)
		(lr-proper-heapp data-seg))
	   (lr-proper-heapp-nodep addr data-seg))
  ((enable lr-proper-heapp lr-proper-heapp1
	   lr-good-pointerp-lessp-offset-max-heap-node
	   definedp-listp-cdr-assoc-lr-proper-p-areasp)
   (use (lr-nodep-lr-proper-heapp-nodep
	 (addr addr)
	 (data-seg data-seg)
	 (max-addr (lr-max-node data-seg))))))

(prove-lemma LR-CHECK-RESULT-F-NOT-LR-F-ADDR (rewrite)
  (implies (and (not (equal (car temp-stk) (lr-f-addr)))
		(lr-proper-p-areasp data-seg)
		(listp temp-stk))
	   (equal (lr-check-result t f temp-stk data-seg orig-temp-stk) f))
  ((enable lr-check-f-addrp lr-check-result lr-proper-heapp-nodep)
   (use (lr-proper-heapp-lr-good-pointerp-lr-proper-heapp-nodep
	 (addr (car temp-stk))
	 (data-seg data-seg)))))

(prove-lemma LR-CHECK-RESULT-T-CHAIN (rewrite)
  (implies (and (not (equal flag 'list))
		(lr-check-result t ans temp-stk2 data-seg2 (cdr temp-stk1))
		(lr-check-result t anything temp-stk1 data-seg1 temp-stk0))
	   (lr-check-result flag ans temp-stk2 data-seg2 temp-stk0))
  ((enable lr-check-result)))

(prove-lemma LR-CHECK-RESULT-NOT-F-LR-F-ADDR (rewrite)
  (implies (and (equal (car temp-stk) (lr-f-addr))
		(listp temp-stk)
		(lr-proper-p-areasp data-seg)
		(not (equal ans f)))
	   (equal (lr-check-result t ans temp-stk data-seg orig-temp-stk)
		  f))
  ((enable lr-check-result lr-proper-heapp-nodep)
   (use (lr-proper-heapp-lr-good-pointerp-lr-proper-heapp-nodep
	 (addr (car temp-stk))
	 (data-seg data-seg)))))

(prove-lemma LR-EVAL-LEAVES-LISTP-P-TEMP-STK (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(not (equal flag 'list))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag l c)) 'run))
	   (listp (p-temp-stk (lr-eval flag l c))))
  ((use (lr-eval-preserves-proper-p-statep-lr->p (l l) (flag flag) (c c)))
   (disable lr-eval)))

(prove-lemma LR-EVAL-S->LR1-IF-OPENER-1 (rewrite)
  (let ((lr-test (lr-if-ok (lr-eval t
				    (lr-set-pos (s->lr1 s l table)
						(dv (s-pos s) 1))
				    c))))
    (implies (and (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (listp (s-expr s))
		  (equal (car (s-expr s)) 'if)
		  (not (equal flag 'list))
		  (equal (p-psw lr-test) 'run)
		  (not (equal (top (p-temp-stk lr-test)) (lr-f-addr))))
	     (equal (lr-eval flag (s->lr1 s l table) c)
		    (lr-eval t
			     (lr-set-expr (lr-pop-tstk lr-test)
					  (s->lr1 s l table)
					  (dv (s-pos s) 2))
			     c))))
  ((expand (lr-eval flag (s->lr1 s l table) c))
   (enable lr-if-ok)
   (disable lr-eval)))

(prove-lemma LR-EVAL-S->LR1-IF-OPENER-2 (rewrite)
  (let ((lr-test (lr-if-ok (lr-eval t
				    (lr-set-pos (s->lr1 s l table)
						(dv (s-pos s) 1))
				    c))))
    (implies (and (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (listp (s-expr s))
		  (equal (car (s-expr s)) 'if)
		  (not (equal flag 'list))
		  (equal (p-psw lr-test) 'run)
		  (equal (top (p-temp-stk lr-test)) (lr-f-addr)))
	     (equal (lr-eval flag (s->lr1 s l table) c)
		    (lr-eval t
			     (lr-set-expr (lr-pop-tstk lr-test)
					  (s->lr1 s l table)
					  (dv (s-pos s) 3))
			     c))))
  ((expand (lr-eval flag (s->lr1 s l table) c))
   (enable lr-if-ok)
   (disable lr-eval)))

(prove-lemma LR-EVAL-S->LR1-IF-OPENER-3 (rewrite)
  (implies (and (good-posp1 (s-pos s) (s-body (s-prog s)))
		(not (equal flag 'list))
		(listp (s-expr s))
		(equal (car (s-expr s)) 'if)
		(not (zerop c))
		(s-good-statep s c)
		(not (equal
		      (p-psw (lr-if-ok (lr-eval t
						(lr-set-pos (s->lr1 s
								    l
								    table)
							    (dv (s-pos s)
								1))
						c)))
		      'run)))
	   (equal (lr-eval flag (s->lr1 s l table) c)
		  (lr-if-ok (lr-eval t
				     (lr-set-pos (s->lr1 s l table)
						 (dv (s-pos s) 1))
				     c))))
  ((expand (lr-eval flag (s->lr1 s l table) c))
   (disable lr-eval)))

(prove-lemma LR-EVAL-S->LR1-TEMP-EVAL-OPENER (rewrite)
  (implies (and (good-posp1 (s-pos s) (s-body (s-prog s)))
		(equal (car (s-expr s)) (s-temp-eval))
		(not (equal flag 'list))
		(not (zerop c))
		(listp (s-expr s))
		(s-good-statep s c))
	   (equal (lr-eval flag (s->lr1 s l table) c)
		  (lr-set-temp (lr-eval t
					(lr-set-pos (s->lr1 s l table)
						    (dv (s-pos s) 1))
					c)
				 (top (p-temp-stk
				       (lr-eval t
						(lr-set-pos (s->lr1 s
								    l
								    table)
						    (dv (s-pos s) 1))
						c)))
				 (caddr (lr-expr (s->lr1 s l table))))))
  ((expand (lr-eval flag (s->lr1 s l table) c))
   (disable lr-eval)))

(prove-lemma LR-EVAL-S->LR1-TEMP-TEST-OPENER (rewrite)
  (implies (and (good-posp1 (s-pos s) (s-body (s-prog s)))
		(equal (car (s-expr s)) (s-temp-test))
		(not (equal flag 'list))
		(not (zerop c))
		(listp (s-expr s))
		(s-good-statep s c))
	   (equal (lr-eval flag (s->lr1 s l table) c)
		  (if (not (lessp (p-max-temp-stk-size l)
				  (plus 2 (length (p-temp-stk l)))))
		      (if (lr-eval-temp-setp (s->lr1 s l table))
			  (lr-do-temp-fetch (s->lr1 s l table))
			  (lr-set-temp
			   (lr-eval t
				    (lr-set-pos (s->lr1 s l table)
						(dv (s-pos s) 1))
				    c)
			   (top (p-temp-stk
				 (lr-eval t
					  (lr-set-pos (s->lr1 s l table)
						      (dv (s-pos s) 1))
					  c)))
			   (caddr (lr-expr (s->lr1 s l table)))))
		      (lr-set-error (s->lr1 s l table)
				    'lr-temp-setp-temp-stack-overflow))))
  ((expand (lr-eval flag (s->lr1 s l table) c))
   (disable lr-eval)))

(prove-lemma LR-EVAL-S->LR1-TEMP-FETCH-OPENER (rewrite)
  (implies (and (good-posp1 (s-pos s) (s-body (s-prog s)))
		(equal (car (s-expr s)) (s-temp-fetch))
		(not (equal flag 'list))
		(not (zerop c))
		(listp (s-expr s))
		(s-good-statep s c))
	   (equal (lr-eval flag (s->lr1 s l table) c)
		  (lr-do-temp-fetch (s->lr1 s l table))))
  ((expand (lr-eval flag (s->lr1 s l table) c))
   (disable lr-eval)))

(prove-lemma LR-EVAL-S->LR1-QUOTE-OPENER (rewrite)
  (implies (and (good-posp1 (s-pos s) (s-body (s-prog s)))
		(equal (car (s-expr s)) 'quote)
		(not (equal flag 'list))
		(not (zerop c))
		(listp (s-expr s))
		(s-good-statep s c))
	   (equal (lr-eval flag (s->lr1 s l table) c)
		  (lr-push-tstk (s->lr1 s l table)
				(cadr (lr-expr (s->lr1 s l table))))))
  ((expand (lr-eval flag (s->lr1 s l table) c))
   (disable lr-eval)))

(prove-lemma LR-PARAMS-LR-SET-TEMP (rewrite)
  (equal (lr-params frame (lr-set-temp l value var-name))
	 (lr-params frame l))
  ((enable lr-params)))

(prove-lemma LR-TEMPS-LR-SET-TEMP (rewrite)
  (equal (lr-temps frame (lr-set-temp l value var-name))
	 (lr-temps frame l))
  ((enable lr-temps)))

(prove-lemma FIRSTN-PUT-ASSOC (rewrite)
  (equal (firstn n (put-assoc val name alist))
	 (put-assoc val name (firstn n alist)))
  ((disable append-firstn-restn)))

(prove-lemma STRIP-CARS-NIL-FACT (rewrite)
  (equal (equal nil (strip-cars y)) (not (listp y))))

(defn INDUCT-HINT-13 (e x y)
  (if (listp x)
      (if (listp y)
	  (if (equal e (caar x))
	      t
	      (induct-hint-13 e (cdr x) (cdr y)))
	  t)
      t))

(prove-lemma STRIP-CARS-EQUAL-DEFINEDP-EQUAL ()
  (implies (equal (strip-cars x) (strip-cars y))
	   (equal (definedp e x) (definedp e y)))
  ((induct (induct-hint-13 e x y))
   (expand (definedp (caar x) y) (strip-cars y))))

(prove-lemma LR-EVAL-PRESERVES-DEFINEDP-FIRSTN-BINDINGS-CAR-P-CTRL-STK (rewrite)
  (implies (and (proper-p-statep (lr->p l))
                (good-posp flag
                           (offset (p-pc l))
                           (program-body (p-current-program l)))
                (lr-programs-properp l table)
                (equal (p-psw (lr-eval flag l c)) 'run))
           (equal (definedp x
			    (firstn n
				    (bindings (car (p-ctrl-stk
						    (lr-eval flag l c))))))
		  (definedp x (firstn n (bindings (car (p-ctrl-stk l)))))))
  ((use (strip-cars-equal-definedp-equal
	 (x (firstn n (bindings (car (p-ctrl-stk (lr-eval flag l c))))))
	 (y (firstn n (bindings (car (p-ctrl-stk l)))))
	 (e x)))
   (enable strip-cars-firstn)
   (disable lr-eval)))

(defn DISJOINTP (list1 list2)
  (if (listp list1)
      (and (not (member (car list1) list2))
	   (disjointp (cdr list1) list2))
      t))

(prove-lemma MEMBER-DISJOINTP-NON-MEMBER-1 ()
  (implies (and (disjointp x y)
		(member e x))
	   (not (member e y))))

(prove-lemma LR-EVAL-PRESERVES-DEFINEDP-FN-BINDINGS-CAR-CTRL-STK-SET-POS (rewrite)
  (implies (and (proper-p-statep (lr->p l))
                (good-posp1 pos (program-body (p-current-program l)))
                (lr-programs-properp l table)
                (equal (p-psw (lr-eval t (lr-set-pos l pos) c)) 'run))
           (equal (definedp x
			    (firstn
			     n
			     (bindings (car (p-ctrl-stk (lr-eval
							 t
							 (lr-set-pos l pos)
							 c))))))
		  (definedp x (firstn n (bindings (car (p-ctrl-stk l)))))))
  ((use (lr-eval-preserves-definedp-firstn-bindings-car-p-ctrl-stk
	 (flag t) (l (lr-set-pos l pos)) (table table) (c c)))
   (enable strip-cars-firstn)
   (disable lr-eval)))

(prove-lemma LR-PARAMS-P-FRAME-NOT-DEFINEDP-PUT-ASSOC-ANYTHING (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(good-posp1 pos (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(disjointp (formal-vars (p-current-program l))
			   (strip-cars (temp-var-dcls
					(p-current-program l))))
		(listp (lr-expr l))
		(or (equal (car (lr-expr l)) (s-temp-eval))
		    (equal (car (lr-expr l)) (s-temp-test)))
		(equal (p-psw (lr-eval t (lr-set-pos l pos) c)) 'run))
	   (equal
	    (lr-params
	     (p-frame (put-assoc anything
				 (caddr (lr-expr l))
				 (bindings (car (p-ctrl-stk
						 (lr-eval t
							  (lr-set-pos l pos)
							  c)))))
		      ret-pc)
	     l)
	    (lr-params (car (p-ctrl-stk (lr-eval t (lr-set-pos l pos) c)))
		       l)))
  ((enable lr-params p-current-program)
   (use (lr-programs-properp-lr-proper-exprp-lr-expr (l l) (table table))
	(proper-p-statep-lr->p-strip-cars-bindings-ctrl-stk (l l))
	(definedp-strip-cars-append-member-x
	  (x (bindings (car (p-ctrl-stk l))))
	  (y (formal-vars (p-current-program l)))
	  (z (strip-cars (temp-var-dcls (p-current-program l))))
	  (e (caddr (lr-expr l))))
	 (member-disjointp-non-member-1
	  (e (caddr (lr-expr l)))
	  (x (formal-vars  (p-current-program l)))
	  (y (strip-cars (temp-var-dcls (p-current-program l))))))
   (disable lr-eval
	    proper-p-statep-lr->p-strip-cars-bindings-ctrl-stk)))

(defn INDUCT-HINT-14 (s-temps lr-temps temp-alist)
  (if (listp s-temps)
      (if (listp lr-temps)
	  (if (listp temp-alist)
	      (if (equal (cdar lr-temps) (lr-undef-addr))
		  (induct-hint-14 (cdr s-temps)
				  (cdr lr-temps)
				  (cdr temp-alist))
		  (induct-hint-14 (cdr s-temps)
				  (cdr lr-temps)
				  (cdr temp-alist)))
	      t)
	  t)
      t))

(prove-lemma PUT-ASSOC-OPENER-1 (rewrite)
  (implies (and (not (equal name (caar alist)))
		(listp alist))
	   (equal (put-assoc val name alist)
		  (cons (car alist) (put-assoc val name (cdr alist))))))

(prove-lemma PUT-ASSOC-OPENER-2 (rewrite)
  (implies (and (listp alist3)
		(not (member (caar alist3) (strip-cars (cdr alist3))))
		(definedp s-expr alist1)
		(equal (strip-cars alist1) (strip-cars alist2))
		(equal (strip-cdrs alist2) (strip-cars (cdr alist3))))
	   (equal (put-assoc val
			     (cdr (assoc s-expr alist2))
			     alist3)
		  (cons (car alist3)
			(put-assoc val
				   (cdr (assoc s-expr alist2))
				   (cdr alist3)))))
  ((use (strip-cars-equal-definedp-equal (x alist1) (y alist2) (e s-expr))
	(cdr-assoc-member-strip-cdrs (name s-expr) (list alist2)))))

(prove-lemma NOT-LR-VALP-LR-UNDEF-ADDR (rewrite)
  (implies (and (lr-proper-heapp data-seg)
		(lr-proper-p-areasp data-seg))
	   (not (lr-valp value (identity (lr-undef-addr)) data-seg)))
  ((enable lr-check-f-addrp lr-check-numberp-addrp lr-proper-heapp-nodep
	   definedp-listp-cdr-assoc-lr-proper-p-areasp
	   lr-minimum-heapp-opener-3)
   (expand (lr-valp value (identity (lr-undef-addr)) data-seg))
   (use (lr-nodep-lr-proper-heapp-nodep
	 (addr (lr-undef-addr))
	 (data-seg data-seg)
	 (max-addr (lr-max-node data-seg)))
	(lr-good-pointerp-lessp-offset-max-heap-node (addr (lr-undef-addr))
						     (data-seg data-seg)))
   (disable lr-valp)))

(prove-lemma LR-S-SIMILAR-TEMPS-PUT-ASSOC-PUT-ASSOC-HELPER-1 (rewrite)
  (implies (and (listp s-temps)
		(listp lr-temps)
		(lr-s-similar-temps s-temps lr-temps data-seg)
		(lr-valp value addr data-seg)
		(lr-proper-heapp data-seg)
		(lr-proper-p-areasp data-seg)
		(equal name1 (caar s-temps))
		(equal name2 (caar lr-temps)))
	   (lr-s-similar-temps (put-assoc (list t value) name1 s-temps)
			       (put-assoc addr name2 lr-temps)
			       data-seg)))

(prove-lemma LR-S-SIMILAR-TEMPS-PUT-ASSOC-PUT-ASSOC-HELPER ()
  (implies (and (lr-s-similar-temps s-temps lr-temps data-seg)
		(lr-valp value addr data-seg)
		(lr-proper-heapp data-seg)
		(lr-proper-p-areasp data-seg)
		(equal (strip-cars temp-alist) (strip-cars s-temps))
		(equal (strip-cdrs temp-alist) (strip-cars lr-temps))
		(no-duplicatesp (strip-cars lr-temps))
		(definedp s-expr s-temps))
	   (lr-s-similar-temps (put-assoc (list t value) s-expr s-temps)
			       (put-assoc addr
					  (cdr (assoc s-expr temp-alist))
					  lr-temps)
			       data-seg))
  ((induct (induct-hint-14 s-temps lr-temps temp-alist))
   (disable lr-valp put-assoc)))

(prove-lemma DISJOINTP-CONS-ARG2 (rewrite)
  (implies (and (disjointp list1 list2)
		(not (member x list1)))
	   (disjointp list1 (cons x list2))))

(prove-lemma DISJOINTP-NLISTP-ARG2 (rewrite)
  (implies (nlistp list2)
	   (disjointp list1 list2)))

(prove-lemma DISJOINTP-LR-MAKE-TEMP-NAME-ALIST-1 (rewrite)
  (disjointp formals
	     (strip-cdrs (lr-make-temp-name-alist-1 initial
						    num-list
						    temp-list
						    formals))))

(prove-lemma LR-S-SIMILAR-STATESP-S-CHANGE-TEMP-HELPER-2 (rewrite)
  (let ((lr-eval (lr-eval t (lr-set-pos (s->lr1 s l table) pos) c)))
    (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (good-posp1 pos (s-body (s-prog s)))
		  (lr-s-similar-statesp s-params
					(s-temps s-eval)
					lr-eval
					table)
		  (lr-programs-properp (s->lr1 s l table) table)
		  (s-good-statep s c)
		  (listp (s-expr s))
		  (or (equal (car (s-expr s)) (s-temp-eval))
		      (equal (car (s-expr s)) (s-temp-test)))
		  (equal (p-psw lr-eval) 'run)
		  (equal lr-expr (caddr (lr-expr (s->lr1 s l table)))))
	   (equal (lr-s-similar-statesp s-params
					(s-temps (s-change-temp s-eval
								s-expr
								value))
					(lr-set-temp lr-eval addr lr-expr)
					table)
		  (lr-s-similar-temps
		   (put-assoc (list t value) s-expr (s-temps s-eval))
		   (lr-temps (p-frame (put-assoc addr
						 lr-expr
						 (bindings
						  (car
						   (p-ctrl-stk lr-eval))))
				      (ret-pc (car (p-ctrl-stk lr-eval))))
			     (s->lr1 s l table))
		   (p-data-segment lr-eval)))))
  ((enable s-change-temp lr-s-similar-statesp s-set-temps)
   (use (lr-programs-properp-lr-proper-exprp-lr-expr (l (s->lr1 s l table))
						     (table table)))
   (disable lr-compile-programs lr-eval lr-s-similar-const-table
	    lr-s-similar-params lr-s-similar-temps)))

(prove-lemma GOOD-POSP1-DV-1-TEMPS-LR-EXPR (rewrite)
  (implies (and (or (equal (car (s-expr s)) (s-temp-eval))
		    (equal (car (s-expr s)) (s-temp-test)))
		(listp (s-expr s))
		(good-posp1 (s-pos s)
			    (s-body (assoc (s-pname s) (s-progs s)))))
	   (good-posp1 (dv (s-pos s) 1)
		       (s-body (assoc (s-pname s) (s-progs s)))))
  ((enable dv s-expr s-prog)
   (expand (good-posp1 '(1)
		       (cur-expr (s-pos s)
				 (s-body (assoc (s-pname s)
						(s-progs s))))))))

(prove-lemma PUT-ASSOC-RESTN (rewrite)
  (implies (not (definedp name (firstn n alist)))
	   (equal (put-assoc val name (restn n alist))
		  (restn n (put-assoc val name alist))))
  ((enable member-strip-cars-definedp)
   (disable append-firstn-restn)))

(prove-lemma DISJOINTP-PLIST-ARG-2 (rewrite)
  (equal (disjointp x (plist y)) (disjointp x y)))

(prove-lemma NOT-DISJOINTP-MEMBER-ARG1-CONS-ARG2 (rewrite)
  (implies (member v y)
	   (not (disjointp y (cons v z))))
  ((use (member-disjointp-non-member-1 (x y) (y (cons v z)) (e v)))))

(prove-lemma MEMBER-DISJOINTP-CONS-ARG2 (rewrite)
  (implies (not (member v y))
	   (equal (disjointp y (cons v z))
		  (disjointp y z))))

(prove-lemma DISJOINTP-COMMUTATIVE ()
  (equal (disjointp x y) (disjointp y x)))

(prove-lemma DISJOINTP-LR-MAKE-TEMP-NAME-ALIST-2 (rewrite)
  (disjointp (strip-cdrs (lr-make-temp-name-alist-1 initial
						    num-list
						    temp-list
						    formals))
	     formals)
  ((use (disjointp-commutative
	 (x formals)
	 (y (strip-cdrs (lr-make-temp-name-alist-1 initial
						   num-list
						   temp-list
						   formals)))))))

(prove-lemma PROPER-P-STATEP-LR->P-S->LR1-STRIP-CARS-BINDINGS-CTRL-STK (rewrite)
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(definedp (s-pname s) (s-progs s)))
	   (equal (strip-cars (bindings (car (p-ctrl-stk l))))
		  (append (s-formals (assoc (s-pname s) (s-progs s)))
			  (strip-cdrs
			   (lr-make-temp-name-alist
			    (s-temp-list (assoc (s-pname s) (s-progs s)))
			    (s-formals (assoc (s-pname s) (s-progs s))))))))
 ((use (proper-p-statep-lr->p-strip-cars-bindings-ctrl-stk
	 (l (s->lr1 s l table))))
  (disable proper-p-statep-lr->p-strip-cars-bindings-ctrl-stk)))

(prove-lemma LR-PROGRAMS-PROPERP-LR->P-S->LR1-DEFINEDP-S-PNAME (rewrite)
  (implies (not (definedp (s-pname s) (s-progs s)))
	   (not (lr-programs-properp (s->lr1 s l table) table)))
  ((enable lr-programs-properp)))

(prove-lemma LR-TEMPS-P-FRAME-PUT-ASSOC (rewrite)
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(lr-programs-properp (s->lr1 s l table) table)
		(definedp (s-pname s) (s-progs s))
		(listp (s-expr s))
		(or (equal (car (s-expr s)) (s-temp-eval))
		    (equal (car (s-expr s)) (s-temp-test)))
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(equal (p-psw (lr-eval t l2 c)) 'run)
		(equal lr-expr (caddr (lr-expr (s->lr1 s l table))))
		(equal l2 (lr-set-pos (s->lr1 s l table) (dv (s-pos s) 1))))
	   (equal
	    (lr-temps (p-frame (put-assoc val
					  lr-expr
					  (bindings
					   (car
					    (p-ctrl-stk (lr-eval t
								 l2
								 c)))))
			       ret-pc)
		      (s->lr1 s l table))
	    (put-assoc val
		       (caddr (lr-expr (s->lr1 s l table)))
		       (lr-temps (car (p-ctrl-stk (lr-eval t l2 c)))
				 (s->lr1 s l table)))))
  ((enable lr-temps s-prog
	   strip-cars-firstn)
   (use (lr-programs-properp-lr-proper-exprp-lr-expr (l (s->lr1 s l table))
						     (table table))
	(member-strip-cars-definedp
	 (y (firstn (length (s-formals (s-prog s)))
                    (bindings (car (p-ctrl-stk (lr-eval t l2 c))))))
         (x (caddr (lr-expr (s->lr1 s l table)))))
	(member-disjointp-non-member-1
	 (e (caddr (lr-expr (s->lr1 s l table))))
	 (x (strip-cars (temp-var-dcls
			 (p-current-program (s->lr1 s l table)))))
	 (y (firstn (length (s-formals (s-prog s)))
		    (strip-cars (bindings (car (p-ctrl-stk l))))))))
   (disable definedp firstn lr-eval member put-assoc restn
	    strip-cars lr-compile-programs
	    not-definedp-put-assoc
	    proper-p-statep-lr->p-strip-cars-bindings-ctrl-stk)))

(prove-lemma STRIP-CARS-LR-TEMPS-STRIP-CARS-TEMP-VAR-DCLS (rewrite)
  (implies (and (s-good-statep s c)
		(proper-p-statep (lr->p (s->lr1 s l table)))
		(equal frame (top (p-ctrl-stk (s->lr1 s l table)))))
	   (equal (strip-cars (lr-temps frame (s->lr1 s l table)))
		  (strip-cdrs (lr-make-temp-name-alist
			       (s-temp-list (assoc (s-pname s)
						   (s-progs s)))
			       (s-formals (assoc (s-pname s)
						 (s-progs s)))))))
  ((enable lr-temps s-prog
	   strip-cars-restn)
   (disable lr-compile-programs lr-make-temp-name-alist)))

(disable proper-p-statep-lr->p-s->lr1-strip-cars-bindings-ctrl-stk)

(prove-lemma LR-S-SIMILAR-STATESP-S-CHANGE-TEMP-HELPER-1 (rewrite)
  (implies (and (good-posp1 (s-pos s) (s-body (s-prog s)))
		(listp (s-expr s))
		(or (equal (car (s-expr s)) (s-temp-eval))
		    (equal (car (s-expr s)) (s-temp-test))
		    (equal (car (s-expr s)) (s-temp-fetch))))
	   (equal (caddr (lr-expr (s->lr1 s l table)))
		  (cdr (assoc (cadr (s-expr s))
			      (lr-make-temp-name-alist
			       (s-temp-list (s-prog s))
			       (s-formals (s-prog s)))))))
  ((enable lr-expr p-current-program s-expr s-prog)
   (expand (lr-compile-body t
			    (cur-expr (s-pos s)
				      (s-body (assoc (s-pname s)
						     (s-progs s))))
			    (lr-make-temp-name-alist
			     (s-temp-list (assoc (s-pname s) (s-progs s)))
			     (s-formals (assoc (s-pname s) (s-progs s))))
			    table))
   (disable lr-compile-body lr-compile-programs
	    lr-make-temp-name-alist lr-s-similar-const-table
	    lr-s-similar-params lr-s-similar-temps)))

(prove-lemma LR-S-SIMILAR-STATESP-S->LR1-LR-SIMILAR-TEMPS ()
  (implies (lr-s-similar-statesp s-params s-temps l table)
	   (lr-s-similar-temps s-temps
			       (lr-temps (top (p-ctrl-stk l)) l)
			       (p-data-segment l)))
  ((enable lr-s-similar-statesp)))

(prove-lemma COUNT-CODELIST1-CONS (rewrite)
  (equal (count-codelist1 (cons x y))
	 (plus x (times 10 (count-codelist1 y)))))

(prove-lemma EQUAL-APPEND-INITIAL (rewrite)
  (equal (equal (append x y) (append x z)) (equal y z)))

(prove-lemma PLIST-LISTP-X-APPEND-X-NOT-0 (rewrite)
  (implies (plistp x)
	   (equal (equal (append x 0) 0) (equal x nil)))
  ((expand (append x 0))))

(prove-lemma EQUAL-APPEND-FINAL-0 (rewrite)
  (equal (equal (append y 0) (append z 0)) (equal (plist y) (plist z)))
  ((induct (induct-hint-11 y z))))

(prove-lemma COUNT-CODELIST1-APPEND-NON-LISTP (rewrite)
  (implies (not (listp z))
	   (equal (count-codelist1 (append num-list z))
		  (count-codelist1 num-list))))

(prove-lemma NOT-EQUAL-MAKE-SYMBOL-CAR-GENSYM (rewrite)
  (implies (lessp (count-codelist1 num-list1) (count-codelist1 num-list2))
	   (not (equal (make-symbol initial num-list1)
		       (car (gensym initial num-list2 atom-list)))))
  ((enable make-symbol
	   pack-equal)
   (induct (gensym initial num-list2 atom-list))))

(prove-lemma COUNT-CODELIST1-CDR-GENSYM (rewrite)
  (implies (lessp (count-codelist1 num-list1) (count-codelist1 num-list2))
	   (lessp (count-codelist1 num-list1)
		  (count-codelist1 (cdr (gensym initial
						num-list2
						atom-list)))))
  ((induct (gensym initial num-list2 atom-list))
   (disable count-codelist1 increment-numlist)))

(prove-lemma NOT-MEMBER-MAKE-SYMBOL-LR-MAKE-TEMP-NAME-ALIST-1-INCR (rewrite)
  (implies (lessp (count-codelist1 num-list1) (count-codelist1 num-list2))
	   (equal (member (make-symbol initial num-list1)
			  (strip-cdrs (lr-make-temp-name-alist-1 initial
								 num-list2
								 temp-list
								 formals)))
		  f)))

(prove-lemma NOT-MEMBER-CAR-GENSYM-LR-MAKE-TEMP-NAME-ALIST-1-CDR (rewrite)
  (equal (member (car (gensym initial num-list atoms))
		 (strip-cdrs (lr-make-temp-name-alist-1
			      initial
			      (cdr (gensym initial num-list atoms))
			      temp-list
			      formals)))
	 f))

(prove-lemma NO-DUPLICATESP-STRIP-CDRS-LR-MAKE-TEMP-NAME-ALIST-1 (rewrite)
  (no-duplicatesp (strip-cdrs (lr-make-temp-name-alist-1 initial
							  num-list
							  temp-list
							  formals))))

(prove-lemma NO-DUPLICATESP-STRIP-CDRS-LR-MAKE-TEMP-NAME-ALIST (rewrite)
  (no-duplicatesp (strip-cdrs (lr-make-temp-name-alist temp-list formals))))

(prove-lemma DEFINEDP-S-TEMPS-S-EVAL (rewrite)
  (implies (equal (s-err-flag (s-eval flag s c)) 'run)
	   (equal (definedp x (s-temps (s-eval flag s c)))
		  (definedp x (s-temps s))))
  ((use (strip-cars-equal-definedp-equal (x (s-temps (s-eval flag s c)))
					 (y (s-temps s))
					 (e x)))
   (disable definedp lr-eval s-eval)))

(prove-lemma STRIP-CARS-LR-MAKE-TEMP-NAME-ALIST-1 (rewrite)
  (equal (strip-cars (lr-make-temp-name-alist-1 initial
						num-list
						temp-list
						formals))
	 (plist temp-list)))

(prove-lemma STRIP-CARS-LR-MAKE-TEMP-NAME-ALIST (rewrite)
  (equal (strip-cars (lr-make-temp-name-alist temp-list formals))
	 (plist temp-list)))

(prove-lemma LR-EVAL-PRESERVES-STRIP-CARS-LR-TEMPS-CAR-P-CTRL-STK (rewrite)
  (implies (and (proper-p-statep (lr->p l))
                (good-posp flag
                           (offset (p-pc l))
                           (program-body (p-current-program l)))
                (lr-programs-properp l table)
                (equal (p-psw (lr-eval flag l c)) 'run))
           (equal (strip-cars (lr-temps (car (p-ctrl-stk (lr-eval flag
								  l
								  c)))
					l2))
		  (strip-cars (lr-temps (car (p-ctrl-stk l)) l2))))
  ((enable lr-temps p-current-program
	   strip-cars-restn)
   (disable lr-eval)))

(prove-lemma LR-S-SIMILAR-STATESP-S-CHANGE-TEMP (rewrite)
  (let ((s-l (s->lr1 s l table))
	(lr-eval (lr-eval t (lr-set-pos (s->lr1 s l table) pos) c)))
    (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		  (lr-s-similar-statesp s-params
					(s-temps s-eval)
					lr-eval
					table)
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (lr-programs-properp (s->lr1 s l table) table)
		  (s-good-statep s c)
		  (listp (p-temp-stk lr-eval))
		  (lr-check-result t
				   (s-ans s-eval)
				   (p-temp-stk lr-eval)
				   (p-data-segment lr-eval)
				   orig-temp-stk)
		  (listp (s-expr s))
		  (or (equal (car (s-expr s)) (s-temp-eval))
		      (equal (car (s-expr s)) (s-temp-test)))
		  (equal (p-psw lr-eval) 'run)
		  (equal (s-err-flag s-eval) 'run)
		  (equal s-eval (s-eval t (s-set-pos s pos) c))
		  (equal value (caddr (lr-expr s-l)))
		  (equal pos (dv (s-pos s) 1)))
	     (lr-s-similar-statesp s-params
				   (s-temps (s-change-temp s-eval
							   (cadr (s-expr s))
							   (s-ans s-eval)))
				   (lr-set-temp lr-eval
						(car (p-temp-stk lr-eval))
						value)
				   table)))
  ((enable lr-check-result s-prog
	   s-good-statep-strip-cars-temps)
   (use (lr-s-similar-statesp-s->lr1-lr-similar-temps
	 (l (lr-eval t (lr-set-pos (s->lr1 s l table) pos) c))
	 (s-temps (s-temps s-eval))
	 (table table) (s-params s-params))
	(lr-s-similar-temps-put-assoc-put-assoc-helper
	 (s-temps (s-temps s-eval))
         (lr-temps (lr-temps
		    (car (p-ctrl-stk (lr-eval t
					      (lr-set-pos (s->lr1 s l table)
							  pos)
					      c)))
		    (lr-eval t (lr-set-pos (s->lr1 s l table) pos) c)))
	 (s-expr (cadr (s-expr s)))
	 (temp-alist (lr-make-temp-name-alist (s-temp-list (s-prog s))
					      (s-formals (s-prog s))))
	 (value (s-ans s-eval))
	 (addr (car (p-temp-stk (lr-eval t
					 (lr-set-pos (s->lr1 s l table) pos)
					 c))))
	 (data-seg (p-data-segment (lr-eval t
					    (lr-set-pos (s->lr1 s l table)
							pos)
					    c))))
	(s-good-statep-definedp-temps (flag t) (s s) (c c))
	(lr-eval-preserves-strip-cars-lr-temps-car-p-ctrl-stk
	 (l (lr-set-pos (s->lr1 s l table) (dv (s-pos s) 1)))
	 (l2 (s->lr1 s l table)) (table table) (c c) (flag t)))
   (disable cur-expr lr-compile-body lr-compile-programs lr-eval
	    lr-s-similar-temps lr-make-temp-name-alist lr-proper-p-areasp
	    lr-valp no-duplicatesp plist put-assoc s-eval
	    good-posp-list-nx-t-simple good-posp1-list-good-posp-list-t
	    lr-eval-preserves-lr-valp
	    s-good-statep-definedp-temps
	    s-eval-l-eval-flag-t)))

(disable lr-s-similar-statesp-s-change-temp-helper-2)

(prove-lemma LR-TEMPS-LR-DO-TEMP-FETCH (rewrite)
  (equal (lr-temps frame (lr-do-temp-fetch l)) (lr-temps frame l))
  ((enable lr-temps)))

(prove-lemma LR-PARAMS-LR-DO-TEMP-FETCH (rewrite)
  (equal (lr-params frame (lr-do-temp-fetch l)) (lr-params frame l))
  ((enable lr-params)))

(prove-lemma LR-S-SIMLAR-STATESP-LR-DO-TEMP-FETCH (rewrite)
  (equal (lr-s-similar-statesp s-params s-temps (lr-do-temp-fetch l) table)
	 (lr-s-similar-statesp s-params s-temps l table))
  ((enable lr-s-similar-statesp)))

(prove-lemma NOT-MEMBER-NO-DUPLICATES-CDR-ASSOC-HELPER ()
  (implies (and (no-duplicatesp list)
		(equal (strip-cdrs alist) list)
		(not (member name list))
		(definedp s-expr alist))
	   (not (equal (cdr (assoc s-expr alist)) name))))

(prove-lemma NOT-MEMBER-NO-DUPLICATES-CDR-ASSOC (rewrite)
  (implies (and (no-duplicatesp list)
		(equal (strip-cdrs alist1) list)
		(not (member name list))
		(definedp s-expr alist2)
		(equal (strip-cars alist2) (strip-cars alist1)))
	   (not (equal (cdr (assoc s-expr alist1)) name)))
  ((use (not-member-no-duplicates-cdr-assoc-helper (name name)
						   (alist alist1)
						   (s-expr s-expr)
						   (list list))
	(strip-cars-equal-definedp-equal
	 (x alist1) (y alist2) (e s-expr)))))

(prove-lemma NOT-EQUAL-LR-S-EVAL-TEMP-SETP-NOT-LR-S-SIMILAR-TEMPS ()
  (implies (and (equal lr-expr (cdr (assoc s-expr temp-alist)))
		(lr-proper-heapp data-seg)
		(lr-proper-p-areasp data-seg)
		(lr-s-similar-temps s-temps lr-temps data-seg)
		(equal (strip-cars temp-alist) (strip-cars s-temps))
		(equal (strip-cdrs temp-alist) (strip-cars lr-temps))
		(no-duplicatesp (strip-cars lr-temps))
		(definedp s-expr s-temps))
	   (iff (not (equal (cdr (assoc lr-expr lr-temps)) (lr-undef-addr)))
		(cadr (assoc s-expr s-temps))))
  ((induct (induct-hint-14 s-temps lr-temps temp-alist))
   (disable lr-valp)))

(prove-lemma DEFINEDP-STRIP-CARS-APPEND-MEMBER-X-2 ()
  (implies (equal (strip-cars x) (append y z))
	   (equal (member e z) (definedp e (restn (length y) x))))
  ((enable member-strip-cars-definedp
	   strip-cars-append)
   (use (length-strip-cars (temp-vars x))
	(length-append (a y) (b z)))
   (disable length-append length-strip-cars)))

(prove-lemma NOT-IFF-LR-S-TEMP-SETP-NOT-LR-S-SIMILAR-STATESP-HELPER (rewrite)
  (implies (and (member x
			(strip-cdrs (lr-make-temp-name-alist
				     (s-temp-list (assoc (s-pname s)
							 (s-progs s)))
				     (s-formals (assoc (s-pname s)
						       (s-progs s))))))
		(proper-p-statep (lr->p (s->lr1 s l table)))
		(definedp (s-pname s) (s-progs s)))
	   (equal (cdr (assoc x (lr-temps (car (p-ctrl-stk l))
					  (s->lr1 s l table))))
		  (cdr (assoc x (bindings (car (p-ctrl-stk l)))))))
  ((enable lr-temps s-prog
	   proper-p-statep-lr->p-s->lr1-strip-cars-bindings-ctrl-stk)
   (use (member-disjointp-non-member-1
	 (e x)
	 (x (strip-cars (temp-var-dcls (p-current-program (s->lr1 s
								  l
								  table)))))
	 (y (formal-vars (p-current-program (s->lr1 s l table)))))
	(assoc-append-1 (x x)
			(list1 (firstn (length (s-formals (s-prog s)))
				       (bindings (car (p-ctrl-stk l)))))
			(list2 (restn (length (s-formals (s-prog s)))
				      (bindings (car (p-ctrl-stk l))))))
	(definedp-strip-cars-append-member-x-2
	  (e x)
	  (x (bindings (car (p-ctrl-stk l))))
	  (z (strip-cars (temp-var-dcls (p-current-program
					 (s->lr1 s l table)))))
	  (y (s-formals (s-prog s))))
	(definedp-strip-cars-append-member-x
	  (e x)
	  (x (bindings (car (p-ctrl-stk l))))
	  (z (strip-cars (temp-var-dcls (p-current-program
					 (s->lr1 s l table)))))
	  (y (s-formals (s-prog s)))))))

(prove-lemma LR-PROGRAMS-PROPERP-MEMBER-LR-EXPR-TEMPS ()
  (implies (and (good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(or (equal (car (lr-expr l)) (s-temp-fetch))
		    (equal (car (lr-expr l)) (s-temp-eval))
		    (equal (car (lr-expr l)) (s-temp-test))))
	   (member (caddr (lr-expr l))
		   (strip-cars (temp-var-dcls (p-current-program l)))))
  ((use (lr-programs-properp-lr-proper-exprp-lr-expr (l l) (table table)))))

(prove-lemma NOT-IFF-LR-S-TEMP-SETP-NOT-LR-S-SIMILAR-STATESP (rewrite)
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(lr-proper-heapp (p-data-segment l))
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(listp (s-expr s))
		(or (equal (car (s-expr s)) (s-temp-test))
		    (equal (car (s-expr s)) (s-temp-fetch)))
		(not (iff (lr-eval-temp-setp (s->lr1 s l table))
			  (s-temp-setp (cadr (s-expr s)) (s-temps s))))
		(s-good-statep s c))
	   (not (lr-s-similar-statesp s-params
				      (s-temps s)
				      (s->lr1 s l table)
				      table)))
  ((enable lr-eval-temp-setp p-current-program s-temp-setp s-prog
	   s-good-statep-strip-cars-temps)
   (use (not-equal-lr-s-eval-temp-setp-not-lr-s-similar-temps
	 (lr-expr (caddr (lr-expr (s->lr1 s l table))))
	 (s-expr (cadr (s-expr s)))
	 (data-seg (p-data-segment l))
	 (s-temps (s-temps s))
	 (lr-temps (lr-temps (car (p-ctrl-stk l)) (s->lr1 s l table)))
	 (temp-alist (lr-make-temp-name-alist (s-temp-list (s-prog s))
					      (s-formals (s-prog s)))))
	(proper-p-statep-lr->p-implies-lr-proper-p-areasp
	 (l (s->lr1 s l table)))
	(s-good-statep-definedp-temps (s s) (c c) (flag flag))
	(lr-programs-properp-member-lr-expr-temps (l (s->lr1 s l table))))
   (disable lr-compile-programs lr-make-temp-name-alist
	    lr-proper-p-areasp lr-s-similar-temps
	    proper-p-statep-lr->p-implies-lr-proper-p-areasp
	    s-good-statep-definedp-temps)))

(prove-lemma LR-VALP-LR-S-EVAL-LR-S-SIMILAR-TEMPS ()
  (implies (and (equal lr-expr (cdr (assoc s-expr temp-alist)))
		(lr-proper-heapp data-seg)
		(lr-proper-p-areasp data-seg)
		(lr-s-similar-temps s-temps lr-temps data-seg)
		(equal (strip-cars temp-alist) (strip-cars s-temps))
		(equal (strip-cdrs temp-alist) (strip-cars lr-temps))
		(no-duplicatesp (strip-cars lr-temps))
		(definedp s-expr s-temps)
		(not (equal (cdr (assoc lr-expr lr-temps))
			    (lr-undef-addr))))
	   (lr-valp (caddr (assoc s-expr s-temps))
		    (cdr (assoc lr-expr lr-temps))
		    data-seg))
  ((induct (induct-hint-14 s-temps lr-temps temp-alist))
   (disable lr-valp)))

(prove-lemma MEMBER-CDR-ASSOC-STRIP-CDRS-DEFINEDP (rewrite)
  (implies (definedp x alist)
	   (member (cdr (assoc x alist)) (strip-cdrs alist))))

(prove-lemma DEFINEDP-PAIRLIST (rewrite)
  (equal (definedp x (pairlist temp-list anything))
	 (member x temp-list)))

(prove-lemma DEFINEDP-LR-MAKE-TEMP-NAME-ALIST-1 (rewrite)
  (equal (definedp x (lr-make-temp-name-alist-1 initial
						num-list
						temp-list
						formals))
	 (member x temp-list))
  ((enable strip-cars-pairlist)
   (use (strip-cars-equal-definedp-equal
	 (e x)
	 (x (pairlist temp-list anything))
	 (y (lr-make-temp-name-alist-1 initial
				       num-list
				       temp-list
				       formals))))))

(prove-lemma DEFINEDP-LR-MAKE-TEMP-NAME-ALIST (rewrite)
  (equal (definedp x (lr-make-temp-name-alist temp-list formals))
	 (member x temp-list)))

(prove-lemma P-TEMP-STK-LR-DO-TEMP-FETCH-P-PSW-RUN (rewrite)
  (implies (equal (p-psw (lr-do-temp-fetch l)) 'run)
	   (equal (p-temp-stk (lr-do-temp-fetch l))
		  (push (local-var-value (caddr (lr-expr l)) (p-ctrl-stk l))
			(p-temp-stk l))))
  ((enable lr-do-temp-fetch lr-push-tstk)))

(prove-lemma LR-CHECK-RESULT-LR-DO-TEMP-FETCH (rewrite)
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(s-good-statep s c)
		(not (zerop c))
		(listp (s-expr s))
		(or (equal (car (s-expr s)) (s-temp-test))
		    (equal (car (s-expr s)) (s-temp-fetch)))
		(lr-proper-heapp (p-data-segment l))
		(lr-s-similar-statesp (s-params s)
				      (s-temps s)
				      (s->lr1 s l table)
				      table)
		(lr-eval-temp-setp (s->lr1 s l table))
		(equal value (caddr (lr-expr (s->lr1 s l table)))))
	   (lr-check-result t
			    (caddr (assoc (cadr (s-expr s)) (s-temps s)))
			    (cons (cdr (assoc value
					      (bindings
					       (car (p-ctrl-stk l)))))
                               (p-temp-stk l))
			    (p-data-segment l)
			    (p-temp-stk l)))
  ((enable lr-check-result lr-eval-temp-setp s-prog
	   s-good-statep-strip-cars-temps)
   (use (lr-valp-lr-s-eval-lr-s-similar-temps
	 (lr-expr (caddr (lr-expr (s->lr1 s l table))))
	 (s-expr (cadr (s-expr s)))
	 (data-seg (p-data-segment l))
	 (s-temps (s-temps s))
	 (lr-temps (lr-temps (car (p-ctrl-stk l)) (s->lr1 s l table)))
	 (temp-alist (lr-make-temp-name-alist (s-temp-list (s-prog s))
					      (s-formals (s-prog s)))))
	(s-good-statep-definedp-temps (s s) (c c) (flag flag))
	(member-strip-cars-definedp (x (cadr (s-expr s))) (y (s-temps s)))
	(lr-s-similar-statesp-s->lr1-lr-similar-temps
	 (s-params (s-params s)) (s-temps (s-temps s))
	 (l (s->lr1 s l table)) (table table))
	(proper-p-statep-lr->p-implies-lr-proper-p-areasp
	 (l (s->lr1 s l table))))
   (disable cur-expr lr-compile-body lr-compile-programs
	    lr-make-temp-name-alist lr-proper-p-areasp lr-valp
	    s-good-statep-definedp-temps
	    not-iff-lr-s-temp-setp-not-lr-s-similar-statesp
	    proper-p-statep-lr->p-implies-lr-proper-p-areasp
	    not-s-good-statep-bad-car-expr)))

(prove-lemma LR-DO-TEMP-FETCH-RUN-LR-EVAL-TEMP-SETP (rewrite)
  (implies (equal (p-psw (lr-do-temp-fetch l)) 'run)
	   (lr-eval-temp-setp l))
  ((enable lr-do-temp-fetch)))

(prove-lemma LR-S-SIMILAR-CONST-TABLE-LR-VALP-ASSOC (rewrite)
  (implies (and (definedp value table)
		(lr-s-similar-const-table table data-seg))
	   (lr-valp value (cdr (assoc value table)) data-seg)))

(prove-lemma LR-PROPER-EXPRP-LIST-QUOTE-OPENER (rewrite)
  (implies (not (equal flag 'list))
	   (equal (lr-proper-exprp flag
				   (list 'quote addr)
				   program-names
				   formals
				   temps
				   table)
		  (and (equal (type addr) 'addr)
		       (member addr (strip-cdrs table))))))

(prove-lemma LR-CHECK-RESULT-LR-PUSH-TSTK-QUOTE (rewrite)
  (implies (and (good-posp1 (s-pos s) (s-body (s-prog s)))
		(listp (s-expr s))
		(equal (car (s-expr s)) 'quote)
		(lr-programs-properp (s->lr1 s l table) table)
		(lr-s-similar-statesp (s-params s)
				      (s-temps s)
				      (s->lr1 s l table)
				      table)
		(s-good-statep s c)
		(lr-proper-heapp (p-data-segment l))
		(equal
		 (p-psw (lr-push-tstk (s->lr1 s l table)
				      (cadr (lr-expr (s->lr1 s
							     l
							     table)))))
		       'run))
	   (lr-check-result t
			    (cadr (s-expr s))
			    (p-temp-stk
			     (lr-push-tstk (s->lr1 s l table)
					   (cadr (lr-expr (s->lr1 s
								  l
								  table)))))
			    (p-data-segment l)
			    (p-temp-stk l)))
  ((enable lr-check-result lr-expr lr-s-similar-statesp
	   lr-push-tstk s-expr)
   (use (lr-programs-properp-lr-proper-exprp-lr-expr (l (s->lr1 s l table))
						     (table table))
	(definedp-assoc-fact-1 (expr (cadr (s-expr s))) (alist table)))
   (disable cur-expr lr-compile-programs lr-s-similar-const-table
	    lr-s-similar-params lr-s-similar-temps lr-make-temp-name-alist
	    lr-proper-exprp lr-valp)))

(prove-lemma LR-EVAL-SUBRP-USER-FUNCALL-OPENER (rewrite)
  (let ((lr-eval-list (lr-eval 'list
			       (lr-set-pos (s->lr1 s l table)
					   (dv (s-pos s) 1))
			       c)))
    (implies (and (not (equal flag 'list))
		  (not (zerop c))
		  (listp (s-expr s))
		  (not (equal (car (s-expr s)) 'if))
		  (not (equal (car (s-expr s)) (s-temp-eval)))
		  (not (equal (car (s-expr s)) (s-temp-test)))
		  (not (equal (car (s-expr s)) (s-temp-fetch)))
		  (not (equal (car (s-expr s)) 'quote))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (s-good-statep s c))
	     (equal
	      (lr-eval flag (s->lr1 s l table) c)
	      (cond ((not (equal (p-psw lr-eval-list) 'run))
		     lr-eval-list)
		    ((subrp (car (s-expr s)))
		     (lr-apply-subr (s->lr1 s l table) lr-eval-list))
		    ((litatom (car (s-expr s)))
		     (lr-set-expr
		      (lr-pop-cstk (lr-eval t
					    (lr-funcall (s->lr1 s l table)
							lr-eval-list)
					    (sub1 c)))
		      (s->lr1 s l table)
		      (s-pos s)))
		    (t (lr-set-error (s->lr1 s l table)
				     'bad-instruction))))))
  ((expand (lr-eval flag (s->lr1 s l table) c))
   (disable lr-eval)))

(prove-lemma LENGTH-CDR-LR-EXPR-FUNCALL (rewrite)
  (implies (and (good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(listp (lr-expr l))
		(or (subrp (car (lr-expr l)))
		    (litatom (car (lr-expr l)))))
	   (equal (length (cdr (lr-expr l))) (arity (car (lr-expr l)))))
  ((use (lr-programs-properp-lr-proper-exprp-lr-expr (l l) (table table)))
   (expand
    (lr-proper-exprp t
		     (lr-expr l)
		     (strip-logic-fnames (cdr (p-prog-segment l)))
		     (formal-vars (p-current-program l))
		     (strip-cars (temp-var-dcls (p-current-program l)))
		     table))
   (disable lr-proper-exprp)))

(defn INDUCT-HINT-8 (n value temp-stk)
  (if (zerop n)
      t
      (induct-hint-8 (sub1 n) (cdr value) (cdr temp-stk))))

(prove-lemma LR-CHECK-RESULT1-LR-VALP-GET-N-LESSP-LENGTH ()
  (implies (and (lr-check-result1 values temp-stk data-seg)
		(lessp n (length values)))
	   (lr-valp (get n values) (get n temp-stk) data-seg))
  ((induct (induct-hint-8 n values temp-stk))
   (disable lr-valp)
   (expand (get n temp-stk)
	   (get n values))))

(prove-lemma LR-VALP-LR-GOOD-POINTERP ()
  (implies (lr-valp value addr data-seg)
	   (lr-good-pointerp addr data-seg))
  ((expand (lr-valp value addr data-seg))
   (disable lr-valp
	    lr-good-pointerp-opener)))

(prove-lemma LR-CHECK-RESULT1-LR-GOOD-POINTERP-GET-N-LESSP-CAR (rewrite)
  (implies (and (lr-check-result1 values temp-stk data-seg)
		(not (lessp (length values) 1)))
	   (and (equal (type (car temp-stk)) 'addr)
		(equal (cddr (car temp-stk)) nil)
		(listp (car temp-stk))
		(adpp (untag (car temp-stk)) data-seg)
		(lr-boundary-nodep (car temp-stk))
		(equal (area-name (car temp-stk)) (identity (lr-heap-name)))
		(equal (type (fetch (add-addr (car temp-stk)
					      (identity
					       (lr-ref-count-offset)))
				    data-seg))
		       'nat)))
  ((use (lr-check-result1-lr-valp-get-n-lessp-length
	 (n 0) (values values) (temp-stk temp-stk) (data-seg data-seg))
	(lr-valp-lr-good-pointerp
	 (value (car values)) (addr (car temp-stk)) (data-seg data-seg)))
   (disable lr-valp)))

(prove-lemma LR-CHECK-RESULT1-LR-GOOD-POINTERP-GET-N-LESSP-CADR (rewrite)
  (implies (and (lr-check-result1 values temp-stk data-seg)
		(not (lessp (length values) 2)))
	   (and (equal (type (cadr temp-stk)) 'addr)
		(equal (cddr (cadr temp-stk)) nil)
		(listp (cadr temp-stk))
		(adpp (untag (cadr temp-stk)) data-seg)
		(lr-boundary-nodep (cadr temp-stk))
		(equal (area-name (cadr temp-stk))
		       (identity (lr-heap-name)))
		(equal (type (fetch (add-addr (cadr temp-stk)
					      (identity
					       (lr-ref-count-offset)))
				    data-seg))
		       'nat)))
  ((use (lr-check-result1-lr-valp-get-n-lessp-length
	 (n 1) (values values) (temp-stk temp-stk) (data-seg data-seg))
	(lr-valp-lr-good-pointerp
	 (value (cadr values)) (addr (cadr temp-stk)) (data-seg data-seg)))
   (disable lr-valp)))

(prove-lemma P-RUN-SUBR-PRESERVES-LR-PROPER-HEAPP2 (rewrite)
  (implies (and (good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(lr-programs-properp new-l table)
		(listp (lr-expr l))
		(proper-p-statep (lr->p new-l))
		(lr-proper-free-listp (p-data-segment new-l))
		(adpp (untag (lr-max-node (p-data-segment new-l)))
		      (p-data-segment new-l))
		(lr-boundary-nodep (lr-max-node (p-data-segment new-l)))
		(equal (p-psw new-l) 'run)
		(equal (p-psw (p-run-subr (car (lr-expr l))
					  (p-set-pc (lr->p new-l)
						    (lr-return-pc l))))
		       'run)
		(lr-proper-heapp2 addr (p-data-segment new-l))
		(lr-nodep addr (p-data-segment new-l))
		(equal (p-prog-segment l) (p-prog-segment new-l))
		(lr-check-result 'list
				 value
				 (p-temp-stk new-l)
				 (p-data-segment new-l)
				 (p-temp-stk l))
		(equal (length value) (length (cdr (lr-expr l)))))
	   (lr-proper-heapp2 addr
			     (p-data-segment
			      (p-run-subr (car (lr-expr l))
					  (p-set-pc (lr->p new-l)
						    (lr-return-pc l))))))
  ((enable p-run-subr p-current-program lr-check-result
	   adpp-deposit-anything-at-all)
   (disable length lr-free-list-nodes lr-p-c-size lr-p-c-size-list
	    deposit-a-list-cons-opener
	    deposit-ref-count-move-outward
	    program-body-assoc-comp-programs)))

(prove-lemma LR-APPLY-SUBR-PRESERVES-LR-PROPER-HEAPP2 (rewrite)
  (let ((new-l (lr-eval 'list (lr-set-pos l pos) c)))
    (implies (and (good-posp1 (offset (p-pc l))
			      (program-body (p-current-program l)))
		  (good-posp 'list pos (program-body (p-current-program l)))
		  (lr-programs-properp l table)
		  (listp (lr-expr l))
		  (subrp (car (lr-expr l)))
		  (not (equal (car (lr-expr l)) 'if))
		  (proper-p-statep (lr->p l))
		  (lr-proper-free-listp (p-data-segment l))
		  (lr-proper-heapp2 addr (p-data-segment new-l))
		  (adpp (untag (lr-max-node (p-data-segment l)))
			(p-data-segment l))
		  (lr-boundary-nodep (lr-max-node (p-data-segment l)))
		  (lr-nodep addr (p-data-segment l))
		  (lr-check-result 'list
				   value
				   (p-temp-stk new-l)
				   (p-data-segment new-l)
				   (p-temp-stk l))
		  (equal (length value) (length (cdr (lr-expr l))))
		  (equal (p-psw new-l) 'run)
		  (equal (p-psw (lr-apply-subr l new-l)) 'run))
	     (lr-proper-heapp2 addr
			       (p-data-segment (lr-apply-subr l new-l)))))
  ((enable good-posp lr-apply-subr)))

(defn INDUCT-HINT-15 (s c)
  (if (listp (s-pos s))
      (if (listp (s-expr-list s))
	  (induct-hint-15 (s-set-expr (s-eval t s c) s (nx (s-pos s))) c)
	  t)
      t)
  ((lessp (number-cons (s-expr-list s)))))

(prove-lemma LENGTH-S-EVAL-LIST (rewrite)
  (implies (and (listp (s-pos s))
		(equal (s-err-flag (s-eval 'list s c)) 'run))
	   (equal (length (s-ans (s-eval 'list s c)))
		  (length (s-expr-list s))))
  ((induct (induct-hint-15 s c))))

(prove-lemma PLISTP-LR-COMPILE-BODY (rewrite)
  (implies (listp body)
	   (plistp (lr-compile-body flag body temp-alist const-alist))))

(prove-lemma PLISTP-LR-EXPR-S->LR1 (rewrite)
  (implies (and (good-posp1 (s-pos s) (s-body (s-prog s)))
		(listp (s-expr s)))
	   (plistp (lr-expr (s->lr1 s l table))))
  ((enable lr-expr s-expr)
   (disable lr-compile-body)))

(prove-lemma LENGTH-CDR-LR-EXPR-FUNCALL-S->LR1 (rewrite)
  (implies (and (good-posp1 (s-pos s) (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(listp (s-expr s))
		(not (equal (car (s-expr s)) 'quote))
		(or (subrp (car (s-expr s)))
		    (litatom (car (s-expr s)))))
          (equal (length (cdr (lr-expr (s->lr1 s l table))))
                 (length (cdr (s-expr s)))))
 ((enable lr-expr s-expr)
  (use (lr-programs-properp-lr-proper-exprp-lr-expr
	(l (s->lr1 s l table)) (table table)))
  (expand (lr-compile-body t
			   (cur-expr (s-pos s) (s-body (s-prog s)))
			   (lr-make-temp-name-alist (s-temp-list (s-prog s))
						    (s-formals (s-prog s)))
			   table))
  (disable cur-expr lr-compile-body lr-make-temp-name-alist
	   length-cdr-lr-expr-funcall)))

(prove-lemma ADPP-SAME-SIGNATURE-LR-APPLY-SUBR (rewrite)
  (implies (same-signature (p-data-segment new-l)
			   (p-data-segment (lr-apply-subr l new-l)))
	   (equal (adpp adp (p-data-segment (lr-apply-subr l new-l)))
		  (adpp adp (p-data-segment new-l))))
  ((use (adpp-same-signature
	 (adp adp)
	 (data-seg1 (p-data-segment (lr-apply-subr l new-l)))
	 (data-seg2 (p-data-segment new-l))))))

(prove-lemma LR-APPLY-SUBR-PRESERVES-LR-PROPER-HEAPP (rewrite)
  (let ((new-l (lr-eval 'list (lr-set-pos (s->lr1 s l table) pos) c)))
    (implies (and (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (definedp (s-pname s) (s-progs s))
		  (lr-programs-properp (s->lr1 s l table) table)
		  (listp (s-expr s))
		  (not (equal (car (s-expr s)) (s-temp-eval)))
		  (not (equal (car (s-expr s)) (s-temp-test)))
		  (not (equal (car (s-expr s)) (s-temp-fetch)))
		  (not (equal (car (s-expr s)) 'quote))
		  (subrp (car (s-expr s)))
		  (not (equal (car (s-expr s)) 'if))
		  (proper-p-statep (lr->p (s->lr1 s l table)))
		  (lr-check-result 'list
				   (s-ans (s-eval 'list
						  (s-set-pos s pos)
						  c))
				   (p-temp-stk new-l)
				   (p-data-segment new-l)
				   (p-temp-stk l))
		  (equal (p-psw new-l) 'run)
		  (equal (p-psw (lr-apply-subr (s->lr1 s l table)
					       new-l))
			 'run)
		  (lr-proper-heapp (p-data-segment new-l))
		  (lr-proper-heapp (p-data-segment l))
		  (equal (s-err-flag (s-eval 'list (s-set-pos s pos) c))
			 'run)
		  (equal pos (dv (s-pos s) 1)))
	     (lr-proper-heapp (p-data-segment (lr-apply-subr (s->lr1 s
								     l
								     table)
							     new-l)))))
  ((enable lr-proper-heapp lr-proper-heapp1
	   lr-minimum-heapp-opener-3
	   lr-minimum-heapp-same-signature
	   lr-max-node-same-signature)
   (use (same-signature-lr-apply-subr
	 (flag flag)
	 (l (s->lr1 s l table))
	 (data-seg (p-data-segment (lr-eval 'list
					    (lr-set-pos (s->lr1 s l table)
							pos)
					    c)))
	 (new-l (lr-eval 'list (lr-set-pos (s->lr1 s l table) pos) c)))
	(lr-apply-subr-preserves-lr-proper-free-listp (l (s->lr1 s l table))
						      (flag flag)
						      (pos pos)
						      (c c))
	(lr-apply-subr-preserves-lr-proper-heapp2
	 (l (s->lr1 s l table))
	 (flag flag)
	 (pos pos)
	 (value (s-ans (s-eval 'list (s-set-pos s pos) c)))
	 (addr (lr-max-node (p-data-segment l)))
	 (c c)))
   (disable lr-compile-body lr-compile-programs lr-eval lr-proper-heapp2
	    lr-valp s-eval
	    length-cdr-lr-expr-funcall
	    lr-apply-subr-preserves-lr-proper-free-listp
	    lr-apply-subr-preserves-lr-proper-heapp2
	    offset-lr-max-node
	    same-signature-lr-apply-subr)))

(prove-lemma LR-S-SIMILAR-PARAMS-LR-APPLY-SUBR (rewrite)
  (let ((new-l (lr-eval 'list (lr-set-pos l pos) c)))
    (implies (and (good-posp1 (offset (p-pc l))
			      (program-body (p-current-program l)))
		  (lr-programs-properp l table)
		  (listp (lr-expr l))
		  (subrp (car (lr-expr l)))
		  (not (equal (car (lr-expr l)) 'if))
		  (proper-p-statep (lr->p new-l))
		  (lr-proper-heapp (p-data-segment new-l))
		  (equal (p-psw new-l) 'run)
		  (equal (p-psw (lr-apply-subr l new-l)) 'run)
		  (lr-s-similar-params s-params
				       lr-params
				       (p-data-segment new-l)))
	     (lr-s-similar-params s-params
				  lr-params
				  (p-data-segment (lr-apply-subr l
								 new-l)))))
  ((disable lr-eval)
   (enable lr-minimum-heapp-opener-3)))

(prove-lemma LR-PARAMS-LR-APPLY-SUBR (rewrite)
  (implies (and (equal (area-name (p-pc new-l)) (area-name (p-pc l)))
		(equal (p-prog-segment new-l) (p-prog-segment l)))
	   (equal (lr-params frame (lr-apply-subr l new-l))
		  (lr-params frame l)))
  ((enable lr-params)))

(prove-lemma LR-TEMPS-LR-APPLY-SUBR (rewrite)
  (implies (and (equal (area-name (p-pc new-l)) (area-name (p-pc l)))
		(equal (p-prog-segment new-l) (p-prog-segment l)))
	   (equal (lr-temps frame (lr-apply-subr l new-l))
		  (lr-temps frame l)))
  ((enable lr-temps)))

(prove-lemma LR-S-SIMILAR-TEMPS-LR-APPLY-SUBR (rewrite)
  (let ((new-l (lr-eval 'list (lr-set-pos l pos) c)))
    (implies (and (good-posp1 (offset (p-pc l))
			      (program-body (p-current-program l)))
		  (lr-programs-properp l table)
		  (listp (lr-expr l))
		  (subrp (car (lr-expr l)))
		  (not (equal (car (lr-expr l)) 'if))
		  (proper-p-statep (lr->p new-l))
		  (lr-proper-heapp (p-data-segment new-l))
		  (equal (p-psw new-l) 'run)
		  (equal (p-psw (lr-apply-subr l new-l)) 'run)
		  (lr-s-similar-temps s-temps
				      lr-temps
				      (p-data-segment new-l)))
	     (lr-s-similar-temps s-temps
				 lr-temps
				 (p-data-segment (lr-apply-subr l new-l)))))
  ((disable lr-eval)
   (enable lr-minimum-heapp-opener-3)))

(prove-lemma LR-S-SIMILAR-CONST-TABLE-LR-APPLY-SUBR (rewrite)
  (let ((new-l (lr-eval 'list (lr-set-pos l pos) c)))
    (implies (and (good-posp1 (offset (p-pc l))
			      (program-body (p-current-program l)))
		  (lr-programs-properp l table1)
		  (listp (lr-expr l))
		  (subrp (car (lr-expr l)))
		  (not (equal (car (lr-expr l)) 'if))
		  (proper-p-statep (lr->p new-l))
		  (lr-proper-heapp (p-data-segment new-l))
		  (equal (p-psw new-l) 'run)
		  (equal (p-psw (lr-apply-subr l new-l)) 'run)
		  (lr-s-similar-const-table table2
					    (p-data-segment new-l)))
	     (lr-s-similar-const-table table2
				       (p-data-segment
					(lr-apply-subr l new-l)))))
  ((disable lr-eval)
   (enable lr-minimum-heapp-opener-3)))

(prove-lemma LR-S-SIMILAR-STATESP-LR-APPLY-SUBR (rewrite)
  (let ((new-l (lr-eval 'list (lr-set-pos l pos) c)))
    (implies (and (good-posp1 (offset (p-pc l))
			      (program-body (p-current-program l)))
		  (lr-programs-properp l table)
		  (listp (lr-expr l))
		  (subrp (car (lr-expr l)))
		  (not (equal (car (lr-expr l)) 'if))
		  (proper-p-statep (lr->p new-l))
		  (lr-proper-heapp (p-data-segment new-l))
		  (equal (p-psw new-l) 'run)
		  (equal (p-psw (lr-apply-subr l new-l)) 'run)
		  (lr-s-similar-statesp s-params s-temps new-l table))
	     (lr-s-similar-statesp s-params
				   s-temps
				   (lr-apply-subr l new-l)
				   table)))
  ((enable lr-s-similar-statesp)
   (disable lr-s-similar-const-table lr-s-similar-params
	    lr-s-similar-temps)))

(prove-lemma PROPER-P-STATEP-LR->P-LR-EVAL-LIST-HELPER (rewrite)
  (let ((cur-expr (cur-expr (offset (p-pc l))
			    (program-body (p-current-program l)))))
    (implies (and (lessp (length cur-expr) 1)
		  (good-posp1 (offset (p-pc l))
			      (program-body (p-current-program l)))
		  (listp cur-expr)
		  (not (equal (car cur-expr) 'if))
		  (not (equal (car cur-expr) 'quote))
		  (or (litatom (car cur-expr)) (subrp (car cur-expr)))
		  (proper-p-statep (lr->p l))
		  (lr-programs-properp l table)
		  (equal (p-psw (lr-eval 'list (lr-set-pos l pos) c)) 'run)
		  (equal pos (dv (offset (p-pc l)) 1)))
	     (proper-p-statep (lr->p (lr-eval 'list
					      (lr-set-pos l pos)
					      c)))))
  ((enable lr-expr-list)
   (expand (lr-eval 'list (lr-set-pos l (dv (offset (p-pc l)) 1)) c)
	   (lessp (length (cur-expr (offset (p-pc l))
				    (program-body (p-current-program l))))
		  1))
   (disable lr-eval)))

(prove-lemma PROPER-P-STATEP-LR->P-LR-EVAL-LIST (rewrite)
  (implies (and (good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(listp (lr-expr l))
		(not (equal (car (lr-expr l)) 'if))
		(not (equal (car (lr-expr l)) 'quote))
		(or (subrp (car (lr-expr l))) (litatom (car (lr-expr l))))
		(proper-p-statep (lr->p l))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval 'list (lr-set-pos l pos) c)) 'run)
		(equal pos (dv (offset (p-pc l)) 1)))
	   (proper-p-statep (lr->p (lr-eval 'list (lr-set-pos l pos) c))))
  ((enable good-posp lr-expr lr-expr-list)
   (use (lr-eval-preserves-proper-p-statep-lr->p-rewrite
	 (l (lr-set-pos l pos)) (flag 'list) (c c)))
   (disable cur-expr lr-eval
	    lr-eval-preserves-proper-p-statep-lr->p-rewrite)))

(disable proper-p-statep-lr->p-lr-eval-list-helper)

(prove-lemma NOT-LISTP-P-TEMP-STK-NOT-LR-CHECK-RESULT1 ()
  (implies (lr-check-result1 value temp-stk data-seg)
	   (not (lessp (length temp-stk) (length value)))))

(prove-lemma RESTN-ADD1-OPENER-ALT (rewrite)
  (equal (restn (add1 n) list)
	 (if (listp list)
	     (restn n (cdr list))
	     list)))

(prove-lemma CDR-P-TEMP-STK-P-RUN-SUBR (rewrite)
  (let ((new-l (lr-eval 'list (lr-set-pos l pos) c)))
    (implies (and (listp (lr-expr l))
		  (not (equal (car (lr-expr l)) 'if))
		  (subrp (car (lr-expr l)))
		  (equal (p-temp-stk l)
			 (restn (length (cdr (lr-expr l)))
				(p-temp-stk new-l)))
		  (lr-check-result1 value
				    (p-temp-stk new-l)
				    (p-data-segment new-l))
		  (equal (length value) (length (cdr (lr-expr l))))
		  (proper-p-statep (lr->p l))
		  (good-posp1 (offset (p-pc l))
			      (program-body (p-current-program l)))
		  (lr-programs-properp l table)
		  (equal (p-psw (p-run-subr (car (lr-expr l))
					    (p-set-pc (lr->p new-l)
						      (lr-return-pc l))))
			 'run)
		  (equal (p-psw new-l) 'run)
		  (equal pos (dv (offset (p-pc l)) 1)))
	     (equal (cdr (p-temp-stk (p-run-subr (car (lr-expr l))
						 (p-set-pc
						  (lr->p new-l)
						  (lr-return-pc l)))))
		    (p-temp-stk l))))
  ((enable p-run-subr p-current-program)
   (use (not-listp-p-temp-stk-not-lr-check-result1
	 (temp-stk (p-temp-stk (lr-eval 'list (lr-set-pos l pos) c)))
	 (data-seg (p-data-segment (lr-eval 'list (lr-set-pos l pos)c)))
	 (value value))
	(lr-programs-properp-lr-eval (l (lr-set-pos l
						    (dv (offset (p-pc l))
							1)))
				     (flag 'list)
				     (c c)
				     (table table)))
   (disable lr-programs-properp-lr-eval
	    restn-add1-opener
	    program-body-assoc-comp-programs)))

(disable restn-add1-opener-alt)

(prove-lemma CDR-P-TEMP-STK-LR-APPLY-SUBR (rewrite)
  (let ((new-l (lr-eval 'list (lr-set-pos l pos) c)))
    (implies (and (listp (lr-expr l))
		  (not (equal (car (lr-expr l)) 'if))
		  (subrp (car (lr-expr l)))
		  (equal (p-temp-stk l)
			 (restn (length (cdr (lr-expr l)))
				(p-temp-stk new-l)))
		  (lr-check-result1 value
				    (p-temp-stk new-l)
				    (p-data-segment new-l))
		  (equal (length value) (length (cdr (lr-expr l))))
		  (proper-p-statep (lr->p l))
		  (good-posp1 (offset (p-pc l))
			      (program-body (p-current-program l)))
		  (lr-programs-properp l table)
		  (equal (p-psw new-l) 'run)
		  (equal (p-psw (lr-apply-subr l new-l)) 'run)
		  (equal pos (dv (offset (p-pc l)) 1)))
	     (equal (cdr (p-temp-stk (lr-apply-subr l new-l)))
		    (p-temp-stk l))))
  ((enable lr-apply-subr)
   (disable lr-eval)))

(prove-lemma LR-CHECK-RESULT1-REVERSE-LENGTH-1-OPENER (rewrite)
  (implies (equal (length values) 1)
	   (equal (lr-check-result1 (reverse values) temp-stk data-seg)
		  (and (lr-valp (car values) (car temp-stk) data-seg)
		       (lr-good-pointerp (car temp-stk) data-seg)))))

(prove-lemma LR-CHECK-RESULT1-REVERSE-LENGTH-2-OPENER (rewrite)
  (implies (equal (length values) 2)
	   (equal (lr-check-result1 (reverse values) temp-stk data-seg)
		  (and (lr-valp (cadr values) (car temp-stk) data-seg)
		       (lr-good-pointerp (cadr temp-stk) data-seg)
		       (lr-valp (car values) (cadr temp-stk) data-seg)
		       (lr-good-pointerp (car temp-stk) data-seg)))))

(prove-lemma LR-VALP-FETCH-TAG-CONS-LR-VALP-CAR-CDR (rewrite)
  (implies (and (lr-valp value addr data-seg)
		(equal (fetch addr data-seg) (tag 'nat (lr-cons-tag))))
	   (and (lr-valp (car value)
			 (fetch (add-addr addr (identity (lr-car-offset)))
				data-seg)
			 data-seg)
		(lr-valp (cdr value)
			 (fetch (add-addr addr (identity (lr-cdr-offset)))
				data-seg)
			 data-seg))))

(prove-lemma LR-GOOD-POINTERP-TYPE-TAG-NAT (rewrite)
  (implies (and (lr-proper-heapp data-seg)
		(lr-good-pointerp addr data-seg))
	   (equal (type (fetch addr data-seg)) 'nat))
  ((enable lr-proper-heapp-nodep
	   lr-good-pointerp-lessp-offset-max-heap-node)
   (use (lr-nodep-lr-proper-heapp-nodep
	 (addr addr)
	 (data-seg data-seg)
	 (max-addr (lr-max-node data-seg))))))

(prove-lemma LR-PROPER-HEAPP-LR-VALP-F-HELPER ()
  (implies (and (lr-proper-heapp-nodep (lr-f-addr) data-seg)
		(lr-proper-heapp-nodep addr data-seg)
		(lr-nodep addr data-seg)
		(lr-minimum-heapp data-seg)
		(lr-proper-p-areasp data-seg))
	   (equal (lr-valp f addr data-seg) (equal addr (lr-f-addr))))
  ((enable lr-good-pointerp lr-check-f-addrp lr-check-undef-addrp
	   lr-proper-heapp-nodep
	   lr-minimum-heapp-opener-3)
   (disable definedp length)
   (do-not-induct t)))

(prove-lemma LR-PROPER-HEAPP-LR-VALP-F (rewrite)
  (implies (and (lr-proper-heapp data-seg)
		(lr-proper-p-areasp data-seg))
	   (equal (lr-valp f addr data-seg) (equal addr (lr-f-addr))))
  ((enable definedp-listp-cdr-assoc-lr-proper-p-areasp
	   lr-good-pointerp-lessp-offset-max-heap-node
	   lr-minimum-heapp-opener-2
	   lr-minimum-heapp-opener-3)
   (use (lr-proper-heapp-lr-valp-f-helper (addr addr) (data-seg data-seg))
	(lr-nodep-lr-proper-heapp-nodep
	 (addr (lr-f-addr))
	 (data-seg data-seg)
	 (max-addr (lr-max-node data-seg)))
	(lr-nodep-lr-proper-heapp-nodep
	 (addr addr)
	 (data-seg data-seg)
	 (max-addr (lr-max-node data-seg))))
   (expand (lr-valp f addr data-seg)
	   (lr-valp f (identity (lr-f-addr)) data-seg))
   (disable lr-valp)
   (do-not-induct t)))

(prove-lemma LR-VALP-EQUAL-VALUE-FACT ()
  (implies (and (lr-valp value1 addr data-seg)
		(lr-valp value2 addr data-seg))
	   (equal value1 value2)))

(prove-lemma LR-PROPER-HEAPP-LR-VALP-0 (rewrite)
  (implies (lr-proper-heapp data-seg)
	   (equal (lr-valp value (identity (lr-0-addr)) data-seg)
		  (equal value 0)))
  ((enable lr-proper-heapp lr-proper-heapp1)
   (disable lr-proper-heapp2 lr-valp)
   (use (lr-valp-equal-value-fact (value1 0)
				  (value2 value)
				  (data-seg data-seg)
				  (addr (lr-0-addr))))))

(prove-lemma LR-PROPER-HEAPP-LR-VALP-LR-F-ADDR (rewrite)
  (implies (and (lr-proper-heapp data-seg)
		(lr-proper-p-areasp data-seg))
	   (equal (lr-valp value (identity (lr-f-addr)) data-seg)
		  (equal value f)))
  ((enable lr-check-undef-addrp lr-proper-heapp-nodep
	   definedp-listp-cdr-assoc-lr-proper-p-areasp
	   lr-minimum-heapp-opener-2
	   lr-minimum-heapp-opener-3)
   (use (lr-nodep-lr-proper-heapp-nodep
	 (addr (lr-f-addr))
	 (data-seg data-seg)
	 (max-addr (lr-max-node data-seg))))))

(prove-lemma LR-PROPER-HEAPP-LR-VALP-LR-T-ADDR (rewrite)
  (implies (lr-proper-heapp data-seg)
	   (equal (lr-valp value (identity (lr-t-addr)) data-seg)
		  (equal value t)))
  ((enable lr-proper-heapp lr-proper-heapp1)
   (use (lr-valp-equal-value-fact (value1 t)
				  (value2 value)
				  (addr (lr-t-addr))
				  (data-seg data-seg)
				  (max-addr (lr-max-node data-seg))))
   (disable lr-proper-heapp2 lr-valp)))

(prove-lemma LR-VALP-FETCH-TAG-NOT-CONS-LR-VALP-CAR-CDR-0 (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(lr-proper-heapp (p-data-segment l))
		(not (equal (fetch (car (p-temp-stk l)) (p-data-segment l))
			    (tag 'nat (lr-cons-tag))))
		(or (not (equal (car value) 0))
		    (not (equal (cdr value) 0))))
	   (not (lr-valp value (car (p-temp-stk l)) (p-data-segment l))))
  ((enable proper-p-statep-bad-type-1)
   (expand (lr-valp value (car (p-temp-stk l)) (p-data-segment l)))
   (disable lr-valp)))

(prove-lemma LR-VALP-NOT-TAG-CONS-NOT-LISTP (rewrite)
  (implies (and (not (listp value))
		(equal (fetch addr data-seg) (tag 'nat (lr-cons-tag))))
	   (not (lr-valp value addr data-seg)))
  ((expand (lr-valp value addr data-seg))
   (disable lr-valp)))

(prove-lemma LR-VALP-FETCH-TAG-NOT-CONS-LR-VALP-LISTP (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(lr-proper-heapp (p-data-segment l))
		(not (equal (fetch (car (p-temp-stk l)) (p-data-segment l))
			    (tag 'nat (lr-cons-tag))))
		(listp value))
	   (not (lr-valp value (car (p-temp-stk l)) (p-data-segment l))))
  ((enable proper-p-statep-bad-type-1)
   (expand (lr-valp value (car (p-temp-stk l)) (p-data-segment l)))
   (disable lr-valp)))

(prove-lemma LR-VALP-CONS (rewrite)
  (equal (lr-valp (cons x y) addr data-seg)
	 (if (lr-good-pointerp addr data-seg)
	     (and (equal (untag (fetch addr data-seg))
			 (lr-cons-tag))
		  (lr-valp x
			   (fetch (add-addr addr (lr-car-offset))
				  data-seg)
			   data-seg)
		  (lr-valp y
			   (fetch (add-addr addr (lr-cdr-offset))
				  data-seg)
			   data-seg))
	     f)))

(prove-lemma LR-VALP-DEPOSIT-A-LIST-CONS (rewrite)
  (implies (and (lr-proper-free-listp data-seg)
		(lr-proper-p-areasp data-seg)
		(lr-nodep (lr-max-node data-seg) data-seg)
		(lr-minimum-heapp data-seg)
		(lr-boundary-nodep (lr-max-node data-seg))
		(lr-valp value addr data-seg)
		(lr-proper-p-areasp data-seg)
		(equal fp-addr (fetch (identity (lr-fp-addr)) data-seg)))
	   (lr-valp value
		    addr
		    (deposit-a-list (list x0 x1 x2 x3)
				    fp-addr
				    data-seg)))
  ((disable-theory addition)
   (enable adpp-deposit-anything-at-all
	   adpp-untag-definedp-area-name
	   commutativity-of-plus
	   lr-minimum-heapp-opener-3
	   lr-valp-deposit-fetch-free-pointer
	   lr-valp-deposit-fetch-free-pointer-offset)
   (disable lr-valp)))

(prove-lemma LR-VALP-CAR-P-TEMP-STK-P-RUN-SUBR-CONS-HELPER (rewrite)
  (implies (and (lr-proper-heapp data-seg)
		(lr-valp car car-addr data-seg)
		(lr-valp cdr cdr-addr data-seg)
		(lr-proper-p-areasp data-seg)
		(equal (type ref-count) 'nat))
	   (lr-valp (cons car cdr)
		    (fetch (identity (lr-fp-addr)) data-seg)
		    (deposit-a-list (list (identity (tag 'nat
							 (lr-cons-tag)))
					  ref-count
					  car-addr
					  cdr-addr)
				    (fetch (identity (lr-fp-addr)) data-seg)
				    data-seg)))
  ((enable difference-plus-cancellation
	   difference-x-x
	   lr-minimum-heapp-opener-3)
   (disable-theory addition)
   (disable plus lr-valp lr-proper-p-areasp
	    deposit-a-list-cons-opener)))

(disable lr-valp-cons)

(prove-lemma LR-VALP-NOT-TAG-TRUE-NOT-LISTP (rewrite)
  (implies (and (not (truep value))
		(equal (fetch addr data-seg) (tag 'nat (lr-true-tag))))
	   (not (lr-valp value addr data-seg)))
  ((expand (lr-valp value addr data-seg))
   (disable lr-valp)))

(prove-lemma LR-VALP-FETCH-TAG-NOT-TRUE-LR-VALP-LISTP (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(lr-proper-heapp (p-data-segment l))
		(not (equal (fetch (car (p-temp-stk l)) (p-data-segment l))
			    (tag 'nat (lr-true-tag)))))
	   (not (lr-valp t (car (p-temp-stk l)) (p-data-segment l))))
  ((enable proper-p-statep-bad-type-1)
   (expand (lr-valp t (car (p-temp-stk l)) (p-data-segment l)))
   (disable lr-valp)))

(prove-lemma LR-VALP-CAR-P-TEMP-STK-P-RUN-SUBR (rewrite)
  (implies (and (lr-proper-heapp (p-data-segment l))
		(lr-check-result1 (reverse values)
				  (p-temp-stk l)
				  (p-data-segment l))
		(equal (length values) (arity subr))
		(proper-p-statep (lr->p l))
		(lr-programs-properp l table)
		(equal (p-psw (p-run-subr subr (p-set-pc (lr->p l) pc)))
		       'run)
		(equal (p-psw l) 'run)
		(equal (area-name pc) (area-name (p-pc l)))
		(equal (unlabel (get (offset pc)
				     (program-body
				      (assoc (area-name pc)
					     (p-prog-segment (lr->p l))))))
		       (list 'call subr)))
	   (lr-valp (apply-subr subr values)
		    (car (p-temp-stk (p-run-subr subr
						 (p-set-pc (lr->p l) pc))))
		    (p-data-segment (p-run-subr subr
						(p-set-pc (lr->p l) pc)))))
  ((enable p-current-program p-run-subr
	   adpp-deposit-anything-at-all)
   (use (lr-programs-properp-lr-programs-properp-1
	 (l l) (table table) (prog-seg (p-prog-segment l))))
   (disable lr-valp lr-check-result1 reverse
	    deposit-a-list-cons-opener
	    lr-programs-properp-lr-programs-properp-1)))

(prove-lemma LR-PROGRAMS-PROPERP-NOT-DEFINEDP-SUBRP-RUNTIME-SUPPORT (rewrite)
  (implies (and (subrp (car (s-expr s)))
		(listp (s-expr s))
		(not (equal (car (s-expr s)) 'if))
		(not (definedp (car (s-expr s))
			       (p-runtime-support-programs)))
		(good-posp1 (s-pos s) (s-body (s-prog s))))
	   (not (lr-programs-properp (s->lr1 s l table) table)))
  ((use (lr-programs-properp-lr-proper-exprp-lr-expr
	 (l (s->lr1 s l table)) (table table)))
   (expand (lr-proper-exprp t 
			    (lr-expr (s->lr1 s l table)) 
			    (strip-logic-fnames
			     (cdr (lr-compile-programs (s-progs s) 
						       table))) 
			    (s-formals (s-prog s)) 
			    (strip-cars (temp-var-dcls (p-current-program
							(s->lr1 s
								l
								table))))
			    table))
   (disable lr-proper-exprp)))

(prove-lemma LR-VALP-APPLY-SUBR-LR-APPLY-SUBR (rewrite)
  (let ((new-l (lr-eval 'list (lr-set-pos (s->lr1 s l table) pos) c)))
    (implies (and (listp (s-expr s))
		  (not (equal (car (s-expr s)) 'if))
		  (not (equal (car (s-expr s)) 'quote))
		  (not (equal (car (s-expr s)) (s-temp-eval)))
		  (not (equal (car (s-expr s)) (s-temp-test)))
		  (not (equal (car (s-expr s)) (s-temp-fetch)))
		  (subrp (car (s-expr s)))
		  (lr-proper-heapp (p-data-segment new-l))
		  (lr-check-result1 (reverse values)
				    (p-temp-stk new-l)
				    (p-data-segment new-l))
		  (equal (length values)
			 (length (cdr (lr-expr (s->lr1 s l table)))))
		  (proper-p-statep (lr->p (s->lr1 s l table)))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (lr-programs-properp (s->lr1 s l table) table)
		  (s-good-statep s c)
		  (equal (p-psw new-l) 'run)
		  (equal (p-psw (lr-apply-subr (s->lr1 s l table)
					       new-l))
			 'run)
		  (equal pos (dv (s-pos s) 1)))
	     (lr-valp (apply-subr (car (s-expr s)) values)
		      (car (p-temp-stk (lr-apply-subr (s->lr1 s l table)
						      new-l)))
		      (p-data-segment (lr-apply-subr (s->lr1 s l table)
						     new-l)))))
  ((enable lr-apply-subr s-prog
	   get-append)
   (use (lr-programs-properp-lr-eval (l (lr-set-pos (s->lr1 s l table)
						    (dv (s-pos s) 1)))
				     (flag 'list)
				     (c c)
				     (table table))
	(get-offset-return-pc-program-body-assoc-comp-programs
	 (l (s->lr1 s l table)) (table table)))
   (disable apply-subr lr-check-result1 lr-compile-body lr-eval
	    lr-make-temp-name-alist lr-valp
	    *1*p-runtime-support-programs
	    length-cdr-lr-expr-funcall-s->lr1
	    lessp-offset-lr-return-pc-lr-p-c-size-good-posp
	    lr-programs-properp-lr-eval)))

(disable lr-programs-properp-not-definedp-subrp-runtime-support)

(prove-lemma LR-CHECK-RESULT-LR-APPLY-SUBR (rewrite)
  (let ((new-l (lr-eval 'list
			(lr-set-pos (s->lr1 s l table) (dv (s-pos s) 1))
			c))
	(pos (dv (s-pos s) 1)))
    (implies (and (listp (s-expr s))
		  (not (equal (car (s-expr s)) 'if))
		  (not (equal (car (s-expr s)) 'quote))
		  (not (equal (car (s-expr s)) (s-temp-eval)))
		  (not (equal (car (s-expr s)) (s-temp-test)))
		  (not (equal (car (s-expr s)) (s-temp-fetch)))
		  (subrp (car (s-expr s)))
		  (lr-check-result 'list
				   (s-ans (s-eval 'list
						  (s-set-pos s pos)
						  c))
				   (p-temp-stk new-l)
				   (p-data-segment new-l)
				   (p-temp-stk l))
		  (proper-p-statep (lr->p (s->lr1 s l table)))
		  (lr-proper-heapp (p-data-segment l))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (lr-programs-properp (s->lr1 s l table) table)
		  (s-good-statep s c)
		  (equal (p-psw new-l) 'run)
		  (equal (p-psw (lr-apply-subr (s->lr1 s l table) new-l))
			 'run)
		  (equal (s-err-flag (s-eval 'list
					     (s-set-pos s (dv (s-pos s) 1))
					     c))
			 'run))
	     (lr-check-result t
			      (apply-subr (car (s-expr s))
					  (s-ans (s-eval 'list
							 (s-set-pos s pos)
							 c)))
			      (p-temp-stk (lr-apply-subr (s->lr1 s l table)
							 new-l))
			      (p-data-segment (lr-apply-subr (s->lr1 s
								     l
								     table)
							     new-l))
			      (p-temp-stk l))))
  ((enable lr-check-result)
   (disable lr-valp lr-eval s-eval
	    length-cdr-lr-expr-funcall)))

(prove-lemma S->LR1-LR-FUNCALL-S-FUN-CALL-STATE (rewrite)
  (implies (and (listp (s-expr s))
		(not (subrp (car (s-expr s))))
		(not (equal (car (s-expr s)) 'quote))
		(not (equal (car (s-expr s)) 'if))
		(litatom (car (s-expr s)))
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(equal (p-psw (lr-funcall (s->lr1 s l table) lr-eval)) 'run)
		(equal (s-progs s-eval) (s-progs s))
		(equal (p-prog-segment lr-eval)
		       (p-prog-segment (s->lr1 s l table))))
	   (equal (s->lr1 (s-fun-call-state s-eval (car (s-expr s)))
			  (lr-funcall (s->lr1 s l table) lr-eval)
			  table)
		  (lr-funcall (s->lr1 s l table) lr-eval)))
  ((enable s->lr1 lr-funcall)
   (use (car-lr-expr-s->lr1 (s s) (l l) (table table)))
   (disable lr-compile-programs lr-eval make-p-call-frame p-call-okp
	    car-lr-expr-s->lr1)))

(prove-lemma LR-PARAMS-LR-FUNCALL (rewrite)
  (implies (and (equal (p-psw (lr-funcall l1 l2)) 'run)
		(equal (p-prog-segment l1) (p-prog-segment l2)))
	   (equal (lr-params (car (p-ctrl-stk (lr-funcall l1 l2)))
			     (lr-funcall l1 l2))
		  (pair-formal-vars-with-actuals
		   (formal-vars (assoc (user-fname (car (lr-expr l1)))
				       (p-prog-segment l1)))
		   (p-temp-stk l2))))
  ((enable lr-params lr-funcall)
   (disable p-call-okp make-p-call-frame)))

(prove-lemma LR-TEMPS-LR-FUNCALL (rewrite)
  (implies (and (equal (p-psw (lr-funcall l1 l2)) 'run)
		(equal (p-prog-segment l1) (p-prog-segment l2)))
	   (equal (lr-temps (car (p-ctrl-stk (lr-funcall l1 l2)))
			    (lr-funcall l1 l2))
		  (pair-temps-with-initial-values
		   (temp-var-dcls (assoc (user-fname (car (lr-expr l1)))
					 (p-prog-segment l1))))))
  ((enable lr-temps lr-funcall)
   (disable p-call-okp make-p-call-frame)))

(prove-lemma LISTP-PAIRLIST (rewrite)
  (equal (listp (pairlist x y)) (listp x)))

(prove-lemma CAR-REVERSE-LAST (rewrite)
  (equal (car (reverse list)) (car (last list))))

(prove-lemma GET-SUB1-LENGTH-CAR-LAST (rewrite)
  (implies (and (listp list)
		(equal n (sub1 (length list))))
	   (equal (get n list) (car (last list))))
  ((enable get)))

(prove-lemma CAR-LAST-FIRST-N-ADD1-GET (rewrite)
  (equal (car (last (first-n (add1 n) list)))
	 (get n list))
  ((induct (get n list))))

(prove-lemma LENGTH-BUTLAST (rewrite)
  (equal (length (butlast x)) (sub1 (length x)))
  ((enable butlast)))

(defn INDUCT-HINT-1 (x y z)
  (if (listp x)
      (if (listp y)
	  (if (listp z)
	      (induct-hint-1 (cdr x) (butlast y) (butlast z))
              t)
          t)
      t))

(prove-lemma LR-CHECK-RESULT1-APPEND-2 (rewrite)
  (implies (equal (length values) (length temp-stk1))
	   (equal (lr-check-result1 values
				    (append temp-stk1 temp-stk2)
				    data-seg)
		  (lr-check-result1 values temp-stk1 data-seg))))

(prove-lemma LR-CHECK-RESULT1-BUTLAST (rewrite)
  (implies (and (lr-check-result1 values temp-stk data-seg)
		(equal (length temp-stk) (length values))
		(listp temp-stk)
		(listp values))
	   (lr-check-result1 (butlast values) (butlast temp-stk) data-seg))
  ((use (lr-check-result1-append (x (butlast values))
				 (y (last values))
				 (temp-stk temp-stk)
				 (data-seg data-seg))
	(lr-check-result1-append-2 (values (butlast values))
				   (temp-stk1 (butlast temp-stk))
				   (temp-stk2 (last temp-stk))
				   (data-seg data-seg)))
   (disable lr-check-result1
	    lr-check-result1-append
	    lr-check-result1-append-2)))

(prove-lemma REVERSE-BUTLAST (rewrite)
  (implies (listp x)
	   (equal (reverse (butlast x)) (cdr (reverse x))))
  ((enable butlast)))

(prove-lemma LR-S-SIMILAR-PARAMS-LR-VALP-GET ()
  (implies (and (lessp n (length s-params))
		(equal (strip-cars s-params) (strip-cars lr-params))
		(lr-s-similar-params s-params lr-params data-seg))
	   (lr-valp (cdr (get n s-params))
		    (cdr (get n lr-params))
		    data-seg))
  ((expand (get n s-params) (get n lr-params))
   (induct (induct-hint-8 n s-params lr-params))
   (disable lr-valp)))

(prove-lemma LR-S-SIMILAR-PARAMS-LR-FUNCALL-HELPER-1 (rewrite)
  (implies (and (lr-s-similar-params (pairlist (cdr formals)
					       (cdr (reverse values)))
				     (pairlist (cdr formals)
					       (cdr (reverse temp-stk)))
				     data-seg)
		(listp formals)
		(listp values)
		(listp temp-stk)
		(lr-check-result1 values temp-stk data-seg)
		(equal (add1 (length (cdr formals))) (length temp-stk))
		(equal (length temp-stk) (length values)))
	   (lr-valp (car (last values)) (car (last temp-stk)) data-seg))
  ((use (lr-s-similar-params-lr-valp-get
	 (s-params (pairlist formals (reverse values)))
	 (lr-params (pairlist formals (reverse temp-stk)))
	 (data-seg data-seg)
	 (n (sub1 (length formals))))
	(lr-check-result1-lr-valp-get-n-lessp-length
	 (values values)
	 (n (sub1 (length values)))
	 (temp-stk temp-stk)
	 (data-seg data-seg)))
   (enable strip-cars-pairlist)
   (disable lr-valp reverse)))

(prove-lemma LR-S-SIMILAR-PARAMS-LR-FUNCALL ()
  (implies (and (lr-check-result1 values temp-stk data-seg)
		(equal (length temp-stk) (length values))
		(equal (length temp-stk) (length formals)))
	   (lr-s-similar-params (pairlist formals (reverse values))
				(pairlist formals (reverse temp-stk))
				data-seg))
  ((induct (induct-hint-1 formals values temp-stk))
   (disable lr-valp)))

(prove-lemma APPEND-FIRST-N-RESTN (rewrite)
  (implies (not (lessp (length l) i))
	   (equal (append (first-n i l) (restn i l)) l)))

(prove-lemma LR-CHECK-RESULT1-FIRST-N-TEMP-STK (rewrite)
  (implies (not (lessp (length (p-temp-stk l)) (length values)))
	   (equal (lr-check-result1 values (p-temp-stk l) data-seg)
		  (lr-check-result1 values
				    (first-n (length values) (p-temp-stk l))
				    data-seg)))
  ((use (lr-check-result1-append-2 (values values)
				   (temp-stk1 (first-n (length values)
						       (p-temp-stk l)))
				   (temp-stk2 (restn (length values)
						     (p-temp-stk l)))
				   (data-seg data-seg)))
   (disable lr-check-result1-append-2)))

(prove-lemma LR-PUSH-TSTK-LENGTH (rewrite)
  (implies (equal (p-psw (lr-push-tstk l object)) 'run)
	   (equal (length (p-temp-stk (lr-push-tstk l object)))
		  (add1 (length (p-temp-stk l)))))
  ((enable lr-push-tstk)))

(prove-lemma LENGTH-ADD1-ADD1-CDDR-FACT ()
  (implies (equal (length x) (add1 (add1 (length y))))
	   (equal (length (cddr x)) (length y))))

(prove-lemma LENGTH-P-TEMP-STK-P-RUN-SUBR-HELPER-1 (rewrite)
  (implies (equal (length (p-temp-stk (lr-eval 'list (lr-set-pos l pos) c)))
		  (add1 (add1 (length (p-temp-stk l)))))
	   (equal (length (cddr (p-temp-stk (lr-eval 'list
						     (lr-set-pos l pos)
						     c))))
		  (length (p-temp-stk l))))
  ((use (length-add1-add1-cddr-fact
	 (x (p-temp-stk (lr-eval 'list (lr-set-pos l pos) c)))
	 (y (p-temp-stk l))))
   (disable lr-eval)))

(prove-lemma LENGTH-P-TEMP-STK-P-RUN-SUBR (rewrite)
  (let ((new-l (lr-eval 'list (lr-set-pos l pos) c)))
    (implies (and (listp (lr-expr l))
		  (not (equal (car (lr-expr l)) 'if))
		  (subrp (car (lr-expr l)))
		  (equal (length (p-temp-stk new-l))
			 (plus (length (p-temp-stk l))
			       (arity (car (lr-expr l)))))
		  (proper-p-statep (lr->p l))
		  (good-posp1 (offset (p-pc l))
			      (program-body (p-current-program l)))
		  (lr-programs-properp l table)
		  (equal (p-psw (p-run-subr (car (lr-expr l))
					    (p-set-pc (lr->p new-l)
						      (lr-return-pc l))))
			 'run)
		  (equal (p-psw new-l) 'run)
		  (equal pos (dv (offset (p-pc l)) 1)))
	     (equal (length (p-temp-stk (p-run-subr (car (lr-expr l))
						    (p-set-pc
						     (lr->p new-l)
						     (lr-return-pc l)))))
		    (add1 (length (p-temp-stk l))))))
  ((enable p-current-program p-run-subr)
   (use (lr-programs-properp-lr-eval (l (lr-set-pos l
						    (dv (offset (p-pc l))
							1)))
				     (flag 'list)
				     (c c)
				     (table table)))
   (disable lr-eval lr-p-c-size
	    get-sub1-length-car-last
	    good-posp1-list-good-posp-list-t
	    good-posp-list-nx-t-simple
	    lessp-offset-lr-return-pc-lr-p-c-size-good-posp
	    lr-programs-properp-lr-eval
	    program-body-assoc-comp-programs)))

(prove-lemma LENGTH-P-TEMP-STK-LR-APPLY-SUBR (rewrite)
  (let ((new-l (lr-eval 'list (lr-set-pos l pos) c)))
    (implies (and (listp (lr-expr l))
		  (not (equal (car (lr-expr l)) 'if))
		  (subrp (car (lr-expr l)))
		  (equal (length (p-temp-stk new-l))
			 (plus (length (p-temp-stk l))
			       (arity (car (lr-expr l)))))
		  (proper-p-statep (lr->p l))
		  (good-posp1 (offset (p-pc l))
			      (program-body (p-current-program l)))
		  (lr-programs-properp l table)
		  (equal (p-psw new-l) 'run)
		  (equal (p-psw (lr-apply-subr l new-l)) 'run)
		  (equal pos (dv (offset (p-pc l)) 1)))
	     (equal (length (p-temp-stk (lr-apply-subr l new-l)))
		    (add1 (length (p-temp-stk l))))))
  ((enable lr-apply-subr)
   (disable lr-eval)))

(defn LR-PROPER-FORMALSP (programs)
  (if (listp programs)
      (and (or (equal (logic-fname (name (car programs))) 'quote)
	       (equal (length (formal-vars (car programs)))
		      (arity (logic-fname (name (car programs))))))
	   (lr-proper-formalsp (cdr programs)))
      t))

(prove-lemma LENGTH-FORMAL-VARS-LR-PROPER-FORMALSP-ARITY (rewrite)
  (implies (and (definedp name programs)
		(not (equal (logic-fname name) 'quote))
		(lr-proper-formalsp programs))
	   (equal (length (formal-vars (assoc name programs)))
		  (arity (logic-fname name))))
  ((enable name)))

(prove-lemma ARITY-FORMALS-NOT-QUOTE (rewrite)
  (implies (and (formals name)
		(not (equal name 'quote)))
	   (equal (arity name) (length (formals name))))
  ((enable arity)
   (disable axiom-53)
   (use (axiom-53 (fn name)))))

(prove-lemma LR-PROPER-FORMALSP-LR-COMPILE-PROGRAMS (rewrite)
  (implies (s-programs-okp programs)
	   (lr-proper-formalsp (lr-compile-programs programs table)))
  ((enable formal-vars name)))

(disable arity-formals-not-quote)

(disable lr-proper-formalsp)

(prove-lemma LR-PROGRAMS-PROPERP-FUNCALL-NOT-CAAR-PROG-SEG (rewrite)
  (implies (and (listp (lr-expr l))
		(not (equal (car (lr-expr l)) 'if))
		(not (equal (car (lr-expr l)) 'quote))
		(not (subrp (car (lr-expr l))))
		(litatom (car (lr-expr l)))
		(listp (p-prog-segment l))
		(equal (user-fname (car (lr-expr l)))
		       (caar (p-prog-segment l)))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l))))
	   (not (lr-programs-properp l table)))
  ((enable lr-programs-properp
	   lr-programs-properp-1-all-user-fnamesp-not-user-fnamep)
   (use (lr-programs-properp-lr-proper-exprp-lr-expr (l l) (table table)))))

(prove-lemma LENGTH-P-TEMP-STK-LR-FUNCALL (rewrite)
  (implies (and (listp (lr-expr l))
		(not (equal (car (lr-expr l)) 'if))
		(not (equal (car (lr-expr l)) 'quote))
		(equal (p-psw new-l) 'run)
		(not (subrp (car (lr-expr l))))
		(litatom (car (lr-expr l)))
		(equal (length (p-temp-stk (lr-eval t
						    (lr-funcall l new-l)
						    (sub1 c))))
		       (add1 (length (p-temp-stk (lr-funcall l new-l)))))
		(equal (length (p-temp-stk new-l))
		       (plus (length (p-temp-stk l))
			     (arity (car (lr-expr l)))))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(lr-proper-formalsp (cdr (p-prog-segment l)))
		(equal (p-psw (lr-funcall l new-l)) 'run))
	   (equal (length (p-temp-stk (lr-funcall l new-l)))
		  (length (p-temp-stk l))))
  ((enable lr-funcall)
   (expand (assoc (user-fname (car (lr-expr l))) (p-prog-segment l)))
   (disable lr-eval make-p-call-frame p-call-okp)))

(prove-lemma LENGTH-P-TEMP-STK-LR-EVAL ()
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(lr-proper-formalsp (cdr (p-prog-segment l)))
		(equal (p-psw (lr-eval flag l c)) 'run))
	   (equal (length (p-temp-stk (lr-eval flag l c)))
		  (if (equal flag 'list)
		      (plus (length (lr-expr-list l))
			    (length (p-temp-stk l)))
		      (plus 1 (length (p-temp-stk l))))))
  ((induct (lr-eval flag l c))
   (enable lr-eval-if-p-psw-1)
   (expand (lr-eval 'list l c) (lr-eval flag l c) (lr-eval flag l 0))
   (disable definedp lr-eval)))

(prove-lemma LENGTH-P-TEMP-STK-LR-EVAL-FLAG-LIST (rewrite)
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(good-posp 'list pos (s-body (s-prog s)))
		(s-good-statep s c)
		(lr-programs-properp (s->lr1 s l table) table)
		(equal (p-psw (lr-eval 'list
				       (lr-set-pos (s->lr1 s l table) pos)
				       c))
		       'run))
	   (equal (length (p-temp-stk (lr-eval 'list
					       (lr-set-pos (s->lr1 s
								   l
								   table)
							   pos)
					       c)))
		  (plus (length (s-expr-list (s-set-pos s pos)))
			(length (p-temp-stk l)))))
  ((use (length-p-temp-stk-lr-eval (flag 'list)
				   (l (lr-set-pos (s->lr1 s l table) pos))
				   (c c)))
   (expand (lr-compile-programs (s-progs s) table))
   (enable good-posp lr-expr-list s-expr-list)
   (disable cur-expr lr-compile-body lr-compile-programs lr-eval
	    lr-make-temp-name-alist)))

(prove-lemma REVERSE-REVERSE-ALT (rewrite)
  (equal (reverse (reverse l)) (plist l))
  ((use (reverse-reverse (l (plist l))))
   (disable reverse-reverse)))

(prove-lemma PAIRLIST-PLIST-1 (rewrite)
  (equal (pairlist x (plist y)) (pairlist x y)))

(prove-lemma S-GOOD-STATEP-LENGTH-CDR-S-EXPR-FUNCALL (rewrite)
  (implies (and (s-good-statep s c)
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(listp (s-expr s))
		(not (equal (car (s-expr s)) 'quote))
		(not (equal (car (s-expr s)) 'if))
		(or (litatom (car (s-expr s)))
		    (subrp (car (s-expr s)))))
	   (equal (length (cdr (s-expr s))) (arity (car (s-expr s)))))
  ((use (s-good-statep-s-proper-exprp-cur-expr (s s) (c c)))
   (expand (s-proper-exprp t
			   (s-expr s)
			   (strip-logic-fnames (cdr (s-progs s)))
			   (s-formals (s-prog s))
			   (s-temp-list (s-prog s))))
   (disable s-proper-exprp
	    l-proper-expr-functions-definedp-s-proper-expr)))

(prove-lemma LR-S-SIMILAR-TEMPS-MAKE-TEMPS-PAIR-TEMPS (rewrite)
  (lr-s-similar-temps (make-temps-entries temp-list)
		      (pair-temps-with-initial-values
		       (lr-make-temp-var-dcls
			(lr-make-temp-name-alist-1 initial
						   num-list
						   temp-list
						   formals)))
		      data-seg))

(prove-lemma LR-S-SIMILAR-TEMPS-LR-FUNCALL (rewrite)
  (lr-s-similar-temps (make-temps-entries (s-temp-list (assoc name progs)))
		      (pair-temps-with-initial-values
		       (temp-var-dcls (assoc name
					     (lr-compile-programs progs
								  table))))
		      data-seg)
  ((enable s-temp-list temp-var-dcls)
   (expand (lr-compile-programs progs table))
   (induct (assoc name progs))
   (disable lr-compile-body lr-compile-programs)))

(prove-lemma LR-EVAL-PRESERVES-LR-S-SIMILAR-CONST-TABLE (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(lr-programs-properp l table1)
		(equal (p-psw (lr-eval flag l c)) 'run)
		(lr-proper-heapp (p-data-segment l))
		(lr-s-similar-const-table table2
					  (p-data-segment l)))
	   (lr-s-similar-const-table table2
				     (p-data-segment (lr-eval flag l c))))
  ((disable definedp lr-eval lr-valp)))

(prove-lemma LR-S-SIMILAR-STATESP-LR-FUNCALL (rewrite)
  (let ((pos (dv (s-pos s) 1)))
    (implies (and (listp (s-expr s))
		  (not (subrp (car (s-expr s))))
		  (not (equal (car (s-expr s)) 'quote))
		  (not (equal (car (s-expr s)) 'if))
		  (litatom (car (s-expr s)))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (proper-p-statep (lr->p (s->lr1 s l table)))
		  (lr-programs-properp (s->lr1 s l table) table)
		  (s-good-statep s c)
		  (equal (p-psw (lr-funcall (s->lr1 s l table)
					    lr-eval))
			 'run)
		  (equal (p-psw lr-eval) 'run)
		  (lr-check-result 'list
				   values
				   (p-temp-stk lr-eval)
				   (p-data-segment lr-eval)
				   (p-temp-stk l))
		  (lr-proper-heapp (p-data-segment l))
		  (equal (s-err-flag (s-eval 'list (s-set-pos s pos) c))
			 'run)
		  (equal formals
			 (s-formals (assoc (user-fname (car (s-expr s)))
					   (s-progs s))))
		  (equal lr-eval
			 (lr-eval 'list
				  (lr-set-pos (s->lr1 s l table) pos)
				  c))
		  (equal values
			 (s-ans (s-eval 'list (s-set-pos s pos) c)))
		  (lr-s-similar-statesp (s-params s)
					(s-temps s)
					(s->lr1 s l table)
					table))
	     (lr-s-similar-statesp (pairlist formals values)
				   (make-temps-entries
				    (s-temp-list (assoc (user-fname
							 (car (s-expr s)))
							(s-progs s))))
				   (lr-funcall (s->lr1 s l table) lr-eval)
				   table)))
  ((enable arity lr-s-similar-statesp lr-check-result)
   (use (lr-s-similar-params-lr-funcall
	 (formals formals)
	 (values (reverse values))
	 (temp-stk (first-n (length values) (p-temp-stk lr-eval)))
	 (data-seg (p-data-segment lr-eval)))
	(lr-programs-properp-lr-set-pos
	 (l (s->lr1 s l table)) (pos (dv (s-pos s) 1)) (table table)))
   (disable lr-check-result1 lr-compile-programs lr-eval lr-s-similar-params
	    lr-s-similar-temps lr-s-similar-const-table reverse s-eval
	    lr-programs-properp-lr-set-pos
	    reverse-reverse)))

(prove-lemma LR-PARAMS-LR-SET-EXPR-LR-POP-CSTK (rewrite)
  (implies (and (equal (area-name (p-pc l)) (area-name (p-pc new-l)))
		(equal (p-prog-segment l) (p-prog-segment new-l)))
	   (equal
	    (lr-params frame
		       (lr-set-expr (lr-pop-cstk (lr-eval t
							  (lr-funcall l
								      new-l)
							  c))
				    l
				    pos))
	    (lr-params frame l)))
  ((enable lr-params p-current-program)))

(prove-lemma LR-TEMPS-LR-SET-EXPR-LR-POP-CSTK (rewrite)
  (implies (and (equal (area-name (p-pc l)) (area-name (p-pc new-l)))
		(equal (p-prog-segment l) (p-prog-segment new-l)))
	   (equal
	    (lr-temps frame
		      (lr-set-expr (lr-pop-cstk (lr-eval t
							 (lr-funcall l
								     new-l)
							 c))
				   l
				   pos))
	    (lr-temps frame l)))
  ((enable lr-temps p-current-program)))

(prove-lemma LR-EVAL-PRESERVES-LR-S-SIMILAR-PARAMS (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag l c))
		       'run)
		(lr-proper-heapp (p-data-segment l))
		(lr-s-similar-params s-params
				     lr-params
				     (p-data-segment l)))
	   (lr-s-similar-params s-params
				lr-params
				(p-data-segment (lr-eval flag l c))))
  ((disable definedp lr-eval lr-valp)))

(prove-lemma LR-EVAL-PRESERVES-LR-S-SIMILAR-TEMPS (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval flag l c))
		       'run)
		(lr-proper-heapp (p-data-segment l))
		(lr-s-similar-temps s-temps
				    lr-temps
				    (p-data-segment l)))
	   (lr-s-similar-temps s-temps
			       lr-temps
			       (p-data-segment (lr-eval flag l c))))
  ((disable definedp lr-eval lr-valp)))

(prove-lemma LR-S-SIMILAR-STATESP-LR-SET-EXPR-LR-POP-CSTK (rewrite)
  (let ((funcall (lr-funcall (s->lr1 s l table)
			     (lr-eval 'list
				      (lr-set-pos (s->lr1 s l table) pos)
				      c)))
	(lr-eval (lr-eval 'list (lr-set-pos (s->lr1 s l table) pos) c)))
    (implies (and (lr-s-similar-statesp (s-params s)
					(s-temps s-eval)
					lr-eval
					table)
		  (listp (s-expr s))
		  (not (subrp (car (s-expr s))))
		  (not (equal (car (s-expr s)) 'quote))
		  (not (equal (car (s-expr s)) 'if))
		  (litatom (car (s-expr s)))
		  (proper-p-statep (lr->p (s->lr1 s l table)))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (lr-programs-properp (s->lr1 s l table) table)
		  (lr-proper-heapp (p-data-segment lr-eval))
		  (equal pos (dv (s-pos s) 1))
		  (equal (p-psw (lr-eval t funcall (sub1 c))) 'run)
		  (equal (p-psw lr-eval) 'run))
	     (lr-s-similar-statesp (s-params s)
				   (s-temps s-eval)
				   (lr-set-expr (lr-pop-cstk
						 (lr-eval t
							  funcall
							  (sub1 c)))
						(s->lr1 s l table)
						(s-pos s))
				   table)))
  ((enable lr-s-similar-statesp)
   (use (lr-programs-properp-lr-funcall
	 (l (s->lr1 s l table)) (pos (dv (s-pos s) 1)) (table table)))
   (disable lr-compile-programs lr-eval lr-s-similar-const-table
	    lr-s-similar-params lr-s-similar-temps
	    lr-programs-properp-lr-funcall)))

(prove-lemma POPN-RESTN (rewrite)
  (implies (not (lessp (length list) n))
	   (equal (popn n list) (restn n list))))

(prove-lemma LR-CHECK-RESULT-LR-FUNCALL (rewrite)
  (let ((new-l (lr-eval 'list
			(lr-set-pos (s->lr1 s l table) (dv (s-pos s) 1))
			c))
	(pos (dv (s-pos s) 1))
	(s-eval (s-eval 'list (s-set-pos s (dv (s-pos s) 1)) c)))
    (implies (and (listp (s-expr s))
		  (not (equal (car (s-expr s)) 'if))
		  (not (equal (car (s-expr s)) 'quote))
		  (not (subrp (car (s-expr s))))
		  (litatom (car (s-expr s)))
		  (lr-check-result 'list
				   (s-ans s-eval)
				   (p-temp-stk new-l)
				   (p-data-segment new-l)
				   (p-temp-stk l))
		  (proper-p-statep (lr->p (s->lr1 s l table)))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (lr-programs-properp (s->lr1 s l table) table)
		  (s-good-statep s c)
		  (equal (p-psw new-l) 'run)
		  (equal (p-psw (lr-funcall (s->lr1 s l table) new-l)) 'run)
		  (equal (s-err-flag s-eval) 'run)
		  (lr-check-result
		   t
		   (s-ans (s-eval t
				  (s-fun-call-state s-eval (car (s-expr s)))
				  (sub1 c)))
		   (p-temp-stk (lr-eval t
					(lr-funcall (s->lr1 s l table)
						    new-l)
					(sub1 c)))
		   (p-data-segment
		    (lr-eval t
			     (lr-funcall (s->lr1 s l table) new-l)
			     (sub1 c)))
		   (p-temp-stk (lr-funcall (s->lr1 s l table) new-l))))
	     (lr-check-result
	      t
	      (s-ans (s-eval t
			     (s-fun-call-state s-eval (car (s-expr s)))
			     (sub1 c)))
	      (p-temp-stk (lr-eval t
				   (lr-funcall (s->lr1 s l table) new-l)
				   (sub1 c)))
	      (p-data-segment (lr-eval t
				       (lr-funcall (s->lr1 s l table) new-l)
				       (sub1 c)))
	      (p-temp-stk l))))
  ((enable arity lr-check-result lr-funcall)
   (disable lr-check-result1 lr-valp lr-eval make-p-call-frame p-call-okp
	    s-eval
	    length-cdr-lr-expr-funcall)))

(disable popn-restn)

(prove-lemma LR-EVAL-S->LR1-FLAG-LIST-OPENER-1 (rewrite)
  (implies (and (good-posp 'list (s-pos s) (s-body (s-prog s)))
		(listp (s-expr-list s))
		(listp (s-pos s))
		(equal (s-err-flag s) 'run))
	   (equal (lr-eval 'list (s->lr1 s l table) c)
		  (lr-eval 'list
			   (lr-set-expr (lr-eval t (s->lr1 s l table) c)
					(s->lr1 s l table)
					(nx (s-pos s)))
			   c)))
  ((expand (lr-eval 'list (s->lr1 s l table) c))
   (disable lr-eval)))

(prove-lemma LR-EVAL-S->LR1-FLAG-LIST-OPENER-2 (rewrite)
  (implies (and (good-posp 'list (s-pos s) (s-body (s-prog s)))
		(not (listp (s-expr-list s)))
		(listp (s-pos s))
		(equal (s-err-flag s) 'run))
	   (equal (lr-eval 'list (s->lr1 s l table) c) (s->lr1 s l table)))
  ((expand (lr-eval 'list (s->lr1 s l table) c))
   (disable lr-eval)))

(prove-lemma LR-CHECK-RESULT-LR-PROPER-HEAPP (rewrite)
  (implies (lr-check-result flag value temp-stk data-seg orig-temp-stk)
	   (lr-proper-heapp data-seg))
  ((enable lr-check-result)
   (disable lr-check-result)))

(prove-lemma LR-PROGRAMS-PROPERP-LR-SET-ERROR (rewrite)
  (equal (lr-programs-properp (lr-set-error l error) table)
	 (lr-programs-properp l table))
  ((enable lr-programs-properp)))

(prove-lemma P-PSW-LR-POP-TSTK-LR-EVAL-FLAG-T (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp1 pos (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-if-ok (lr-eval t
						 (lr-set-pos l pos)
						 c)))
		       'run))
	   (equal (p-psw (lr-pop-tstk (lr-if-ok (lr-eval t
							 (lr-set-pos l pos)
							 c))))
		  'run))
  ((enable lr-pop-tstk lr-if-ok)
   (use (lr-eval-leaves-listp-p-temp-stk
	 (l (lr-set-pos l pos)) (flag t) (c c) (table table)))
   (disable lr-eval
	    lr-eval-leaves-listp-p-temp-stk)))

(prove-lemma LR-EVAL-LEAVES-LISTP-P-TEMP-STK-LR-SET-POS (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp1 pos (program-body (p-current-program l)))
		(lr-programs-properp l table)
		(equal (p-psw (lr-eval t (lr-set-pos l pos) c)) 'run))
	   (listp (p-temp-stk (lr-eval t (lr-set-pos l pos) c))))
  ((use (lr-eval-leaves-listp-p-temp-stk
	 (l (lr-set-pos l pos)) (flag t) (c c) (table table)))
   (disable lr-eval
	    lr-eval-leaves-listp-p-temp-stk)))

(prove-lemma P-PSW-RUN-LR-IF-OK-P-PSW-RUN (rewrite)
  (implies (equal (p-psw (lr-if-ok l)) 'run)
	   (equal (p-psw l) 'run))
  ((enable lr-if-ok)))

(prove-lemma LR-S-SIMILAR-STATESP-LR-IF-OK (rewrite)
  (equal (lr-s-similar-statesp s-params s-temps (lr-if-ok l) table)
	 (lr-s-similar-statesp s-params s-temps l table))
  ((enable lr-s-similar-statesp lr-params lr-temps p-current-program)
   (disable lr-s-similar-const-table lr-s-similar-temps
	    lr-s-similar-params)))

(prove-lemma LR-EVAL-S-EVAL-EQUIVALENCE ()
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(lr-proper-heapp (p-data-segment l))
		(good-posp flag (s-pos s) (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(lr-s-similar-statesp (s-params s)
				      (s-temps s)
				      (s->lr1 s l table)
				      table)
		(s-good-statep s c)
		(equal (p-psw (lr-eval flag (s->lr1 s l table) c)) 'run))
	   (and (lr-s-similar-statesp (s-params s)
				      (s-temps (s-eval flag s c))
				      (lr-eval flag (s->lr1 s l table) c)
				      table)
		(lr-check-result (if (equal flag 'list) 'list t)
				 (s-ans (s-eval flag s c))
				 (p-temp-stk (lr-eval flag
						      (s->lr1 s l table)
						      c))
				 (p-data-segment (lr-eval flag
							  (s->lr1 s l table)
							  c))
				 (p-temp-stk l))
		(equal (s-err-flag (s-eval flag s c)) 'run)))
  ((induct (ihint-2 flag s l table c))
   (enable lr-eval-if-p-psw-1)
   (expand (s-eval flag s c) (s-eval 'list s c) (s-eval flag s 0))
   (disable definedp lr-compile-programs lr-eval lr-make-temp-name-alist
	    s-eval
	    good-posp-list-nx-t-simple
	    good-posp1-cons-lessp-4-if-lr-proper-exprp
	    formal-vars-lr-compile-programs
	    proper-p-statep-lr->p-strip-cars-bindings-ctrl-stk
	    s-eval-l-eval-flag-run-flag-t
	    s-eval-l-eval-flag-run-helper-5
	    s-eval-l-eval-flag-t
	    temp-var-dcls-lr-compile-programs)))

(disable p-psw-run-lr-if-ok-p-psw-run)

; ------------------------------------------------------------
; was lr-eval5.events
; ------------------------------------------------------------


;; The following define functions for each SUBR that tell how many
;; resources are used.  In the computations of the maximum control
;; stack size we break out the parts needed for formals and
;; temporaries and building a new control-stack frame.  For example in
;; CONS we have (plus 2 0 1 ...), the 2 is for building a new frame,
;; the 0 is for the formals (CONS leaves its args on the temp stack)
;; and 1 for temporaries.
(defn S-APPLY-CAR-R (s)
  (list 1 (plus 2 1 0 0) 0 0))

(defn S-APPLY-CDR-R (s)
  (list 1 (plus 2 1 0 0) 0 0))

;; CONS takes two implicit args
(defn S-APPLY-CONS-R (s)
  (list 2 (plus 2 0 1 0) 0 1))

(defn S-APPLY-FALSE-R (s)
  (list 1 (plus 2 0 0 0) 0 0))

;; FALSEP takes one implicit arg on stack.
(defn S-APPLY-FALSEP-R (s)
  (list 1 (plus 2 0 0 0) 0 0))

;; LISTP takes an implicit arg
(defn S-APPLY-LISTP-R (s)
  (list 1 (plus 2 0 0 0) 0 0))

;; NLISTP takes an implicit arg
(defn S-APPLY-NLISTP-R (s)
  (list 1 (plus 2 0 0 0) 0 0))

(defn S-APPLY-TRUE-R (s)
  (list 1 (plus 2 0 0 0) 0 0))

(defn S-APPLY-TRUEP-R (s)
  (list 1 (plus 2 0 0 0) 0 0))

(defn S-APPLY-SUBR-R (subr s)
  (case subr
    (car		(s-apply-car-r s))
    (cdr		(s-apply-cdr-r s))
    (cons		(s-apply-cons-r s))
    (false		(s-apply-false-r s))
    (falsep		(s-apply-falsep-r s))
    (listp		(s-apply-listp-r s))
    (nlistp		(s-apply-nlistp-r s))
    (true		(s-apply-true-r s))
    (truep		(s-apply-truep-r s))
    (otherwise		(list 0 0 0 0))))

(defn MAX-R (list1 list2)
  (list (max (car list1) (car list2))
	(max (cadr list1) (cadr list2))
	(max (caddr list1) (caddr list2))
	(plus (cadddr list1) (cadddr list2))))

(disable max-r)

(defn S-ADD-TEMP-R (list n)
  (list (plus n (car list)) (cadr list) (caddr list) (cadddr list)))

;; S-EVAL-R is somewhat similar to S-EVAL.  It returns a list of four
;; numbers representing.  the maximum temp stack size, maximum ctrl stack
;; size, maximum word size and number of free heap nodes respectively needed
;; to execute the compilation of the S-STATE s in Piton without getting an
;; error.
(defn S-EVAL-R (flag s c)
  (cond ((not (equal (s-err-flag s) 'run)) (list 0 0 0 0))
	((equal flag 'list)
	 (if (nlistp (s-pos s))
	     (list 0 0 0 0)
	     (if (listp (s-expr-list s))
		 (max-r (s-eval-r t s c)
			(s-add-temp-r (s-eval-r 'list
						(s-set-expr (s-eval t s c)
							    s
							    (nx (s-pos s)))
						c)
				      1))
		 (list 0 0 0 0))))
	((zerop c) (list 0 0 0 0))
	((litatom (s-expr s)) (list 1 0 0 0))
	((nlistp (s-expr s)) (list 0 0 0 0))
	((equal (car (s-expr s)) 'if)
	 (let ((test (s-eval t (s-set-pos s (dv (s-pos s) 1)) c)))
	   (if (equal (s-err-flag test) 'run)
	       (if (s-ans test)
		   (max-r (s-add-temp-r (s-eval-r t
						  (s-set-pos s
							     (dv (s-pos s)
								 1))
						  c)
					1)
			  (s-eval-r t
				    (s-set-expr test s (dv (s-pos s) 2))
				    c))
		   (max-r (s-add-temp-r (s-eval-r t
						  (s-set-pos s
							     (dv (s-pos s)
								 1))
						  c)
					1)
			  (s-eval-r t
				    (s-set-expr test s (dv (s-pos s) 3))
				    c)))
	       (s-eval-r t (s-set-pos s (dv (s-pos s) 1)) c))))
	((equal (car (s-expr s)) (s-temp-eval))
	 (s-eval-r t (s-set-pos s (dv (s-pos s) 1)) c))
	((equal (car (s-expr s)) (s-temp-test))
	 ;; We need two words on the temp stack to do S-TEMP-SETP
	 (if (s-temp-setp (cadr (s-expr s)) (s-temps s))
	     (list 2 0 0 0)
	     (max-r (list 2 0 0 0)
		    (s-eval-r t (s-set-pos s (dv (s-pos s) 1)) c))))
	((equal (car (s-expr s)) (s-temp-fetch)) (list 1 0 0 0))
	((equal (car (s-expr s)) 'quote) (list 1 0 0 0))
	((not (equal (s-err-flag (s-eval 'list
					 (s-set-pos s (dv (s-pos s) 1))
					 c))
		     'run))
	 (s-eval-r 'list (s-set-pos s (dv (s-pos s) 1)) c))
	((subrp (car (s-expr s)))
	 ;; Since some subrs take args on temp stack S-APPLY-SUBR-R
	 ;; needs to account for that
	 (max-r (s-eval-r 'list (s-set-pos s (dv (s-pos s) 1)) c)
		(s-add-temp-r (s-apply-subr-r
			       (car (s-expr s))
			       (s-eval 'list
				       (s-set-pos s (dv (s-pos s) 1))
				       c))
			      (arity (car (s-expr s))))))
	((litatom (car (s-expr s)))
	 (let ((arg-s (s-eval 'list (s-set-pos s (dv (s-pos s) 1)) c)))
	   (let ((fstate (s-fun-call-state arg-s (car (s-expr s)))))
	     (let ((arg-r (s-eval-r t fstate (sub1 c))))
	       (max-r (s-eval-r 'list (s-set-pos s (dv (s-pos s) 1)) c)
		      (list (car arg-r)
			    (plus 2
				  (length (s-params fstate))
				  (length (s-temps fstate))
				  (cadr arg-r))
			    (caddr arg-r)
			    (cadddr arg-r)))))))
	(t (list 0 0 0 0)))
  ((ord-lessp (cons (add1 c)
		    (if (equal flag 'list)
			(number-cons (s-expr-list s))
			(number-cons (s-expr s)))))))

(defn S-EVAL-TEMP-R (flag s c)
  (car (s-eval-r flag s c)))

(defn S-EVAL-CTRL-R (flag s c)
  (cadr (s-eval-r flag s c)))

(defn S-EVAL-WS-R (flag s c)
  (caddr (s-eval-r flag s c)))

(defn S-EVAL-HEAP-R (flag s c)
  (cadddr (s-eval-r flag s c)))

(defn S-MAX-SUBR-REQS ()
  (max (log 2 (lr-cons-tag))
       (max (log 2 (lr-true-tag))
	    (max (log 2 (lr-cdr-offset))
		 (log 2 (lr-car-offset))))))

(disable s-max-subr-reqs)

(prove-lemma NUMBERP-CAR-CADR-CADDR-CADDDR-S-APPLY-SUBR-R (rewrite)
  (and (numberp (car (s-apply-subr-r subr s)))
       (numberp (cadr (s-apply-subr-r subr s)))
       (numberp (caddr (s-apply-subr-r subr s)))
       (numberp (cadddr (s-apply-subr-r subr s)))))

(disable s-apply-subr-r)

(prove-lemma NUMBERP-MAX-R (rewrite)
  (and (numberp (car (max-r list1 list2)))
       (numberp (cadr (max-r list1 list2)))
       (numberp (caddr (max-r list1 list2)))
       (numberp (cadddr (max-r list1 list2))))
  ((enable max-r)))

(prove-lemma NUMBERP-S-EVAL-TEMP-CTRL-WS-HEAP-R (rewrite)
  (and (numberp (s-eval-temp-r flag s c))
       (numberp (s-eval-ctrl-r flag s c))
       (numberp (s-eval-ws-r flag s c))
       (numberp (s-eval-heap-r flag s c)))
  ((induct (s-eval-r flag s c))
   (expand (s-eval-r flag s c) (s-eval-r 'list s c) (s-eval-r flag s 0))
   (disable s-eval-r)))

(disable s-eval-temp-r)
(disable s-eval-ctrl-r)
(disable s-eval-ws-r)
(disable s-eval-heap-r)

(defn LR-COUNT-FREE-NODES (addr node-list data-seg)
  (if (member addr node-list)
      (add1 (lr-count-free-nodes (fetch (add-addr addr
						  (lr-ref-count-offset))
					data-seg)
				 (delete addr node-list)
				 data-seg))
      0)
  ((lessp (length node-list))))

(defn LR-CHECK-RESOURCESP (flag s l c)
  (and (not (lessp (p-max-temp-stk-size l)
		   (plus (length (p-temp-stk l))
			 (s-eval-temp-r flag s c))))
       (not (lessp (p-max-ctrl-stk-size l)
		   (plus (p-ctrl-stk-size (p-ctrl-stk l))
			 (s-eval-ctrl-r flag s c))))
       (not (lessp (p-word-size l) (s-eval-ws-r flag s c)))
       (not (lessp (lr-count-free-nodes
		    (fetch (lr-fp-addr) (p-data-segment l))
		    (lr-free-list-nodes
		     (lr-max-node (p-data-segment l))
		     (p-data-segment l))
		    (p-data-segment l))
		   (s-eval-heap-r flag s c)))))

(disable lr-check-resourcesp)

(prove-lemma NOT-LESSP-MAX-R-CAR (rewrite)
  (and (not (lessp (car (max-r list1 list2)) (car list1)))
       (not (lessp (car (max-r list1 list2)) (car list2))))
  ((enable max-r)))

(prove-lemma NOT-LESSP-MAX-R-CADR (rewrite)
  (and (not (lessp (cadr (max-r list1 list2)) (cadr list1)))
       (not (lessp (cadr (max-r list1 list2)) (cadr list2))))
  ((enable max-r)))

(prove-lemma NOT-LESSP-MAX-R-CADDR (rewrite)
  (and (not (lessp (caddr (max-r list1 list2)) (caddr list1)))
       (not (lessp (caddr (max-r list1 list2)) (caddr list2))))
  ((enable max-r)))

(prove-lemma NOT-LESSP-MAX-R-CADDDR (rewrite)
  (and (not (lessp (cadddr (max-r list1 list2)) (cadddr list1)))
       (not (lessp (cadddr (max-r list1 list2)) (cadddr list2))))
  ((enable max-r)))

(prove-lemma LR-CHECK-RESOURCESP-LISTP-S-EXPR-LIST (rewrite)
  (implies (and (equal (s-err-flag s) 'run)
		(listp (s-pos s))
		(listp (s-expr-list s))
		(good-posp 'list (s-pos s) (s-body (s-prog s)))
		(lr-check-resourcesp 'list s l c))
	   (lr-check-resourcesp t s l c))
  ((enable lr-check-resourcesp s-eval-ctrl-r s-eval-heap-r s-eval-temp-r
	   s-eval-ws-r)
   (expand (s-eval-r 'list s c))
   (disable s-eval-r)))

(prove-lemma LR-EVAL-PRESERVES-LR-PROPER-HEAPP (rewrite)
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(lr-proper-heapp (p-data-segment l))
		(good-posp flag (s-pos s) (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(lr-s-similar-statesp (s-params s)
				      (s-temps s)
				      (s->lr1 s l table)
				      table)
		(s-good-statep s c)
		(equal (p-psw (lr-eval flag (s->lr1 s l table) c)) 'run))
	   (lr-proper-heapp (p-data-segment (lr-eval flag
						     (s->lr1 s l table)
						     c))))
  ((use (lr-eval-s-eval-equivalence
	 (flag flag) (s s) (l l) (table table) (c c)))
   (enable lr-check-result)
   (disable lr-check-result1 lr-eval lr-valp)))

(prove-lemma LR-EVAL-PRESERVES-LR-S-SIMILAR-STATESP (rewrite)
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(lr-proper-heapp (p-data-segment l))
		(good-posp flag (s-pos s) (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(lr-s-similar-statesp (s-params s)
				      (s-temps s)
				      (s->lr1 s l table)
				      table)
		(s-good-statep s c)
		(equal (p-psw (lr-eval flag (s->lr1 s l table) c)) 'run))
	   (lr-s-similar-statesp (s-params s)
				 (s-temps (s-eval flag s c))
				 (lr-eval flag (s->lr1 s l table) c)
				 table))
  ((use (lr-eval-s-eval-equivalence
	 (flag flag) (s s) (l l) (table table) (c c)))
   (disable lr-eval s-eval)))

(prove-lemma S-EVAL-FLAG-RUN-FLAG-T-SUBSETP-S-COLLECT-ALL-TEMPS (rewrite)
  (implies (and (s-good-statep s c)
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(s-all-temps-setp flag
				  (s-expr s)
				  (temp-alist-to-set (s-temps s)))
		(s-all-progs-temps-setp (s-progs s))
		(equal (s-err-flag (s-eval flag s c)) 'run)
		(s-check-temps-setp (s-temps s))
		(not (equal flag 'list)))
	   (subsetp (s-collect-all-temps flag (s-expr s))
		    (temp-alist-to-set (s-temps (s-eval flag s c)))))
  ((disable l-eval s-eval)
   (use (s-eval-l-eval-equivalence (flag flag) (s s) (c c)))))

(prove-lemma S-EVAL-FLAG-RUN-FLAG-T-S-CHECK-TEMPS-SETP (rewrite)
  (implies (and (s-good-statep s c)
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(s-all-temps-setp flag
				  (s-expr s)
				  (temp-alist-to-set (s-temps s)))
		(s-all-progs-temps-setp (s-progs s))
		(equal (s-err-flag (s-eval flag s c)) 'run)
		(s-check-temps-setp (s-temps s))
		(not (equal flag 'list)))
	   (s-check-temps-setp (s-temps (s-eval flag s c))))
  ((disable l-eval s-eval)
   (use (s-eval-l-eval-equivalence (flag flag) (s s) (c c)))))

(prove-lemma LR-EVAL-PRESERVES-LENGTH-BINDINGS-CAR-P-CTRL-STK (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(lr-programs-properp l table)
                (equal (p-psw (lr-eval flag l c)) 'run))
           (equal (length (bindings (car (p-ctrl-stk (lr-eval flag l c)))))
                  (length (bindings (car (p-ctrl-stk l))))))
  ((use (length-strip-cars (temp-vars (bindings (car (p-ctrl-stk l)))))
	(length-strip-cars
	 (temp-vars (bindings (car (p-ctrl-stk (lr-eval flag l c)))))))
   (disable lr-eval
	    length-strip-cars
	    proper-p-statep-lr->p-strip-cars-bindings-ctrl-stk)))

(prove-lemma LR-EVAL-S->LR1-PRESERVES-P-CTRL-STK-SIZE (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag
			   (offset (p-pc l))
			   (program-body (p-current-program l)))
		(lr-programs-properp l table)
                (equal (p-psw (lr-eval flag l c)) 'run))
           (equal (p-ctrl-stk-size (p-ctrl-stk (lr-eval flag l c)))
                  (p-ctrl-stk-size (p-ctrl-stk l))))
  ((expand (p-ctrl-stk-size (p-ctrl-stk (lr-eval flag l c)))
	   (p-ctrl-stk-size (p-ctrl-stk l)))
   (use (lr-eval-preserves-proper-p-statep-lr->p-rewrite
	 (flag flag) (l l) (c c)))
   (disable lr-eval p-ctrl-stk-size
	    lr-eval-preserves-proper-p-statep-lr->p-rewrite
	    proper-p-statep-lr->p-strip-cars-bindings-ctrl-stk)))

(prove-lemma LENGTH-P-TEMP-STK-LR-EVAL-FLAG-NOT-LIST (rewrite)
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(good-posp flag (s-pos s) (s-body (s-prog s)))
		(s-good-statep s c)
		(lr-programs-properp (s->lr1 s l table) table)
		(equal (p-psw (lr-eval flag (s->lr1 s l table) c)) 'run)
		(not (equal flag 'list)))
	   (equal (length (p-temp-stk (lr-eval flag (s->lr1 s l table) c)))
		  (plus 1 (length (p-temp-stk l)))))
  ((use (length-p-temp-stk-lr-eval
	 (flag flag) (l (s->lr1 s l table)) (c c)))
   (expand (lr-compile-programs (s-progs s) table))
   (disable lr-compile-body lr-compile-programs lr-eval)))

(prove-lemma LR-EVAL-PRESERVES-LR-PROPER-HEAPP-LR-SET-POS (rewrite)
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(lr-proper-heapp (p-data-segment l))
		(good-posp flag pos (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(lr-s-similar-statesp (s-params s)
				      (s-temps s)
				      (s->lr1 s l table)
				      table)
		(s-good-statep s c)
		(equal (p-psw (lr-eval flag
				       (lr-set-pos (s->lr1 s l table) pos)
				       c))
		       'run))
	   (lr-proper-heapp
	    (p-data-segment (lr-eval flag
				     (lr-set-pos (s->lr1 s l table) pos)
				     c))))
  ((enable lr-check-result)
   (use (lr-eval-s-eval-equivalence
	 (s (s-set-pos s pos)) (flag flag) (l l) (table table) (c c)))
   (disable lr-eval s-eval lr-check-result1)))

(prove-lemma LR-EVAL-PRESERVES-LR-S-SIMILAR-STATESP-LR-SET-POS (rewrite)
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(lr-proper-heapp (p-data-segment l))
		(good-posp flag pos (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(lr-s-similar-statesp (s-params s)
				      (s-temps s)
				      (s->lr1 s l table)
				      table)
		(s-good-statep s c)
		(equal (p-psw (lr-eval flag
				       (lr-set-pos (s->lr1 s l table) pos)
				       c))
		       'run))
	   (lr-s-similar-statesp (s-params s)
				 (s-temps (s-eval flag (s-set-pos s pos) c))
				 (lr-eval flag
					  (lr-set-pos (s->lr1 s l table)
						      pos)
					  c)
				 table))
  ((use (lr-eval-s-eval-equivalence
	 (flag flag) (s (s-set-pos s pos)) (l l) (table table) (c c)))
   (disable lr-eval s-eval)))

(prove-lemma LR-EVAL-S-EVAL-FLAG-T-S-ANS-F-LR-SET-POS (rewrite)
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(lr-proper-heapp (p-data-segment l))
		(good-posp1 pos (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(lr-s-similar-statesp (s-params s)
				      (s-temps s)
				      (s->lr1 s l table)
				      table)
		(s-good-statep s c)
		(equal (p-psw (lr-eval t
				       (lr-set-pos (s->lr1 s l table) pos)
				       c))
		       'run)
		(not (s-ans (s-eval t (s-set-pos s pos) c))))
	   (equal (car (p-temp-stk (lr-eval t
					    (lr-set-pos (s->lr1 s l table)
							pos)
					    c)))
		  (lr-f-addr)))
  ((enable lr-check-result)
   (use (lr-eval-s-eval-equivalence
	 (flag t) (s (s-set-pos s pos)) (l l) (table table) (c c)))
   (disable lr-check-result1 lr-eval lr-valp s-eval)))

(prove-lemma LR-EVAL-S-EVAL-FLAG-T-S-ANS-NON-F-LR-SET-POS (rewrite)
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(lr-proper-heapp (p-data-segment l))
		(good-posp1 pos (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(lr-s-similar-statesp (s-params s)
				      (s-temps s)
				      (s->lr1 s l table)
				      table)
		(s-good-statep s c)
		(equal (p-psw (lr-eval t
				       (lr-set-pos (s->lr1 s l table) pos)
				       c))
		       'run)
		(s-ans (s-eval t (s-set-pos s pos) c)))
	   (not (equal (car (p-temp-stk (lr-eval t
						 (lr-set-pos (s->lr1 s
								     l
								     table)
							     pos)
						 c)))
		       (identity (lr-f-addr)))))
  ((enable lr-check-result)
   (use (lr-eval-s-eval-equivalence
	 (flag t) (s (s-set-pos s pos)) (l l) (table table) (c c)))
   (disable lr-check-result1 lr-eval lr-valp s-eval)))

(prove-lemma SUBSETP-NOT-MEMBER-BOTH (rewrite)
  (implies (and (not (member addr set2))
		(subsetp set1 set2))
	   (not (member addr set1))))

(prove-lemma LR-COUNT-FREE-NODES-DEPOSIT-FREE-PTR (rewrite)
  (implies (and (adpp '(free-ptr . 0) data-seg)
		(lr-node-listp node-list data-seg))
	   (equal (lr-count-free-nodes addr
				       node-list
				       (deposit anything
						(identity (lr-fp-addr))
						data-seg))
		  (lr-count-free-nodes addr node-list data-seg)))
  ((enable lr-node-listp-delete)))

(prove-lemma LR-COUNT-FREE-NODES-DEPOSIT-NON-REF-COUNT (rewrite)
  (implies (and (lr-nodep addr2 data-seg)
		(not (equal offset (lr-ref-count-offset)))
		(numberp offset)
		(lessp offset (lr-node-size))
		(lr-node-listp node-list data-seg))
	   (equal (lr-count-free-nodes addr1
				       node-list
				       (deposit anything
						(add-addr addr2 offset)
						data-seg))
		  (lr-count-free-nodes addr1 node-list data-seg)))
  ((enable lr-boundary-nodep
	   adpp-untag-numberp-offset
	   adpp-untag-listp
	   commutativity-of-plus
	   lr-node-listp-delete
	   lr-nodep-member-lr-node-listp
	   lr-nodep-member-lr-node-listp-adpp-untag-listp
	   lr-nodep-member-lr-node-listp-adpp-untag-numberp-offset)
   (disable-theory addition)
   (disable delete lr-boundary-offsetp
	    delete-delete
	    delete-non-member
	    member-delete
	    member-non-list
	    no-duplicatesp-occurences-1)))

(prove-lemma LR-COUNT-FREE-NODES-DEPOSIT-LR-NODEP (rewrite)
  (implies (and (lr-nodep addr2 data-seg)
		(lr-node-listp node-list data-seg))
	   (equal (lr-count-free-nodes addr1
				       node-list
				       (deposit anything addr2 data-seg))
		  (lr-count-free-nodes addr1 node-list data-seg)))
  ((use (lr-count-free-nodes-deposit-non-ref-count (addr2 addr2)
						   (data-seg data-seg)
						   (offset 0)
						   (node-list node-list)
						   (anything anything)))
   (enable adpp-add-addr-0)
   (disable lr-count-free-nodes-deposit-non-ref-count)))

(prove-lemma LR-COUNT-FREE-NODES-DELETE-DEPOSIT (rewrite)
  (implies (and (not (member addr1 node-list))
		(lr-nodep addr1 data-seg)
		(lr-node-listp node-list data-seg)
		(equal (type ref-count) 'nat)
		(numberp (untag ref-count)))
	   (equal (lr-count-free-nodes addr2
				       node-list
				       (deposit
					ref-count
					(add-addr addr1
						  (identity
						   (lr-ref-count-offset)))
					data-seg))
		  (lr-count-free-nodes addr2 node-list data-seg)))
  ((enable adpp-untag-definedp-area-name
	   adpp-untag-listp
	   adpp-untag-numberp-offset
	   commutativity-of-plus plus-zero-arg2
	   member-area-name-offset-same
	   lr-node-listp-delete
	   lr-nodep-member-lr-node-listp
	   lr-nodep-member-lr-node-listp-adpp-untag-listp
	   lr-nodep-member-lr-node-listp-adpp-untag-numberp-offset)
   (expand (lr-count-free-nodes addr2
				node-list
				(deposit ref-count
					 (add-addr addr1
						   (identity
						    (lr-ref-count-offset)))
					 data-seg)))
   (induct (lr-count-free-nodes addr2 node-list data-seg))
   (disable-theory addition)
   (disable delete
	    delete-delete delete-non-member
	    equal-length-0
	    member-delete member-non-list
	    no-duplicatesp-occurences-1)))

(prove-lemma LR-COUNT-FREE-NODES-MAX-ADDR-LR-FREE-LIST-NODES (rewrite)
  (equal (lr-count-free-nodes max-addr
			      (lr-free-list-nodes max-addr data-seg1)
			      data-seg2)
	 0)
  ((enable lr-free-list-nodes-member-greater-offset)
   (do-not-induct t)))

(prove-lemma LR-COUNT-LR-FREE-LIST-NODES-P-RUN-CONS (rewrite)
  (let ((dds (deposit-a-list (list (identity (tag 'nat 5))
				   ref-count
				   any1
				   any2)
			     (fetch (identity (lr-fp-addr)) data-seg)
			     data-seg)))
    (implies (and (lr-proper-heapp data-seg)
		  (equal max-addr (lr-max-node data-seg))
		  (equal (type ref-count) 'nat)
		  (numberp (untag ref-count))
		  (not (equal (fetch (identity (lr-fp-addr)) data-seg)
			      max-addr)))
	     (equal (add1 (lr-count-free-nodes
			   (fetch (add-addr (fetch (identity (lr-fp-addr))
						   data-seg)
					    (identity
					     (lr-ref-count-offset)))
				  data-seg)
			   (lr-free-list-nodes max-addr
					       dds)
			   dds))
		    (lr-count-free-nodes (fetch (identity (lr-fp-addr))
						data-seg)
					 (lr-free-list-nodes max-addr
							     data-seg)
					 data-seg))))
  ((enable lr-proper-free-listp
	   adpp-deposit-anything-at-all
	   deposit-ref-count-move-inward-2
	   fetch-lr-nodep-add-addr
	   lr-node-listp-deposit-anything-at-all
	   lr-node-listp-delete)
   (use (adpp-untag-definedp-area-name (addr (lr-fp-addr))
				       (data-seg data-seg))
	(lr-proper-heapp-opener-1 (data-seg data-seg)))
   (expand (lr-count-free-nodes (fetch (identity (lr-fp-addr)) data-seg)
				(lr-free-list-nodes (lr-max-node data-seg)
						    data-seg)
				data-seg)
	   (lr-check-free-nodes (fetch (identity (lr-fp-addr)) data-seg)
				(lr-free-list-nodes (lr-max-node data-seg)
						    data-seg)
				data-seg
				(lr-max-node data-seg)))
   (disable-theory addition)
   (disable delete length lr-check-free-nodes lr-count-free-nodes
	    lr-free-list-nodes
	    deposit-ref-count-move-outward
	    lr-proper-heapp-opener-1
	    lr-proper-free-listp-opener-1
	    not-adpp-untag-add-addr-adpp-untag)))

(prove-lemma NOT-P-MAX-NODE-FETCH-FP-ADDR-NOT-ERRORP-P-RUN-CONS (rewrite)
  (implies (and (equal (p-psw (p (p-set-pc (lr->p new-l) pc)
				 (p-cons-clock (p-set-pc (lr->p new-l)
							 pc))))
		       'run)
		(proper-p-statep (lr->p new-l))
		(proper-p-statep (p-set-pc (lr->p new-l) pc))
		(equal max-node (lr-max-node (p-data-segment new-l)))
		(equal (p-psw new-l) 'run)
		(lr-programs-properp new-l table)
		(lr-proper-heapp (p-data-segment new-l))
		(equal
		 (unlabel (get (offset pc)
			       (program-body
				(assoc (area-name pc)
				       (p-prog-segment (lr->p new-l))))))
		 '(call cons)))
	   (not (equal (fetch (identity (lr-fp-addr))
			      (p-data-segment new-l))
		       max-node)))
  ((use (same-signature-p-run-subr (subr 'cons)
				   (p (p-set-pc (lr->p new-l) pc))
				   (data-seg (p-data-segment new-l))))
   (enable p-run-subr
	   adpp-deposit-anything-at-all
	   definedp-listp-cdr-assoc-lr-proper-p-areasp
	   lr-minimum-heapp-opener-3
	   not-same-signature-deposit-too-large-addr
	   same-signature-deposit)
   (disable length
	    length-deposit
	    not-adpp-untag-add-addr-adpp-untag)))

(prove-lemma GET-COMP-BODY-LR-COMPILE-PROGRAMS (rewrite)
  (implies (and (good-posp1 (s-pos s) (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(not (equal (car (s-expr s)) 'if))
		(not (equal (car (s-expr s)) (s-temp-eval)))
		(not (equal (car (s-expr s)) (s-temp-test)))
		(not (equal (car (s-expr s)) (s-temp-fetch)))
		(not (equal (car (s-expr s)) 'quote))
		(listp (s-expr s)))
	   (equal (get (offset (lr-return-pc (s->lr1 s l table)))
		       (program-body (assoc (s-pname s)
					    (comp-programs
					     (lr-compile-programs
					      (s-progs s)
					      table)))))
		  (list 'dl
			(lr-make-label (offset (lr-return-pc
						(s->lr1 s l table))))
			()
			(if (definedp (car (s-expr s))
				      (p-runtime-support-programs))
			    (list 'call (car (s-expr s)))
			    (list 'call (user-fname (car (s-expr s))))))))
  ((enable s-prog)
   (use (get-offset-return-pc-program-body-assoc-comp-programs
	 (body (program-body (p-current-program (s->lr1 s l table))))
	 (l (s->lr1 s l table))
	 (table table)))
   (disable lr-make-temp-name-alist
	    get-offset-return-pc-program-body-assoc-comp-programs)))

(prove-lemma LR-COUNT-LR-FREE-LIST-NODES-P-RUN-SUBR ()
  (let ((p (p-set-pc (lr->p (lr-eval 'list
				     (lr-set-pos (s->lr1 s l table) pos)
				     c))
		     (lr-return-pc (s->lr1 s l table))))
	(new-l (lr-eval 'list (lr-set-pos (s->lr1 s l table) pos) c)))
    (implies (and (listp (s-expr s))
		  (not (equal (car (s-expr s)) 'if))
		  (subrp (car (s-expr s)))
		  (proper-p-statep (lr->p (s->lr1 s l table)))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (lr-programs-properp (s->lr1 s l table) table)
		  (s-good-statep s c)
		  (equal (p-psw (p-run-subr (car (s-expr s)) p)) 'run)
		  (equal (p-psw new-l) 'run)
		  (equal pos (dv (s-pos s) 1))
		  (lr-proper-heapp (p-data-segment l))
		  (lr-s-similar-statesp (s-params s)
					(s-temps s)
					(s->lr1 s l table)
					table))
	     (equal
	      (lr-count-free-nodes (fetch (identity (lr-fp-addr))
					  (p-data-segment new-l))
				   (lr-free-list-nodes
				    (lr-max-node (p-data-segment l))
				    (p-data-segment new-l))
				   (p-data-segment new-l))
	      (plus (lr-count-free-nodes
		     (fetch (identity (lr-fp-addr))
			    (p-data-segment (p-run-subr (car (s-expr s))
							p)))
		     (lr-free-list-nodes
		      (lr-max-node (p-data-segment l))
		      (p-data-segment (p-run-subr (car (s-expr s)) p)))
		     (p-data-segment (p-run-subr (car (s-expr s)) p)))
		    (cadddr (s-apply-subr-r (car (s-expr s))
					    (s-eval 'list
						    (s-set-pos s pos)
						    c)))))))
    ((enable p-run-subr s-apply-subr-r
	     adpp-deposit-anything-at-all)
     (use (adpp-cons-pack-definedp-area-name
	   (xxx (unpack (area-name (lr-fp-addr))))
	   (offset (offset (lr-fp-addr)))
	   (data-seg (p-data-segment (lr-eval 'list
					      (lr-set-pos (s->lr1 s l table)
							  pos)
					      c))))
	  (lr-programs-properp-lr-eval
	   (flag 'list) (l (lr-set-pos (s->lr1 s l table) pos))
	   (c c) (table table)))
     (disable lr-compile-body lr-compile-programs lr-count-free-nodes length
	      lr-eval lr-free-list-nodes lr-make-temp-name-alist lr-p-c-size
	      s-eval
	      adpp-cons-pack-definedp-area-name
	      deposit-a-list-cons-opener
	      good-posp-list-nx-t-simple
	      good-posp1-nlistp
	      get-sub1-length-car-last
	      lr-eval-zerop-clock
	      lr-programs-properp-lr-eval
	      program-body-assoc-comp-programs)))

(prove-lemma LR-COUNT-LR-FREE-LIST-NODES-LR-APPLY-SUBR (rewrite)
  (let ((new-l (lr-eval 'list (lr-set-pos (s->lr1 s l table) pos) c)))
    (implies (and (listp (s-expr s))
		  (not (equal (car (s-expr s)) 'if))
		  (subrp (car (s-expr s)))
		  (proper-p-statep (lr->p (s->lr1 s l table)))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (lr-programs-properp (s->lr1 s l table) table)
		  (equal (p-psw new-l) 'run)
		  (equal (p-psw (lr-apply-subr (s->lr1 s l table)
					       new-l))
			 'run)
		  (s-good-statep s c)
		  (lr-proper-heapp (p-data-segment l))
		  (lr-s-similar-statesp (s-params s)
					(s-temps s)
					(s->lr1 s l table)
					table)
		  (equal pos (dv (s-pos s) 1))
		  (equal max-addr (lr-max-node (p-data-segment l)))
		  (equal s-eval-size
			 (s-eval-heap-r 'list (s-set-pos s pos) c))
		  (equal (plus (lr-count-free-nodes
				(fetch (lr-fp-addr) (p-data-segment new-l))
				(lr-free-list-nodes max-addr
						    (p-data-segment new-l))
				(p-data-segment new-l))
			       s-eval-size)
			 (lr-count-free-nodes
			  (fetch (lr-fp-addr)
				 (p-data-segment l))
			  (lr-free-list-nodes max-addr (p-data-segment l))
			  (p-data-segment l))))
	     (equal (plus s-eval-size
			  (cadddr (s-apply-subr-r (car (s-expr s))
						  (s-eval 'list
							  (s-set-pos s pos)
							  c)))
			  (lr-count-free-nodes
			   (fetch (identity (lr-fp-addr))
				  (p-data-segment
				   (lr-apply-subr (s->lr1 s l table)
						  new-l)))
			   (lr-free-list-nodes
			    max-addr
			    (p-data-segment (lr-apply-subr (s->lr1 s
								   l
								   table)
							   new-l)))
			   (p-data-segment (lr-apply-subr (s->lr1 s l table)
							  new-l))))
		    (lr-count-free-nodes
		     (fetch (identity (lr-fp-addr)) (p-data-segment l))
		     (lr-free-list-nodes max-addr
					 (p-data-segment l))
		     (p-data-segment l)))))
  ((enable lr-apply-subr)
   (disable lr-eval s-eval lr-count-free-nodes lr-free-list-nodes)
   (use (lr-count-lr-free-list-nodes-p-run-subr
	 (s s) (l l) (table table) (c c) (max-addr max-addr) (pos pos)))))

(prove-lemma LR-EVAL-S-EVAL-EQUIVALENCE-LR-CHECK-RESULT-FLAG-LIST (rewrite)
  (let ((lr-eval (lr-eval 'list
			  (lr-set-pos (s->lr1 s l table) (dv (s-pos s) 1))
			  c)))
    (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		  (lr-proper-heapp (p-data-segment l))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (lr-programs-properp (s->lr1 s l table) table)
		  (lr-s-similar-statesp (s-params s)
					(s-temps s)
					(s->lr1 s l table)
					table)
		  (s-good-statep s c)
		  (equal (p-psw lr-eval) 'run)
		  (listp (s-expr s))
		  (not (equal (car (s-expr s)) 'if))
		  (not (equal (car (s-expr s)) (s-temp-eval)))
		  (not (equal (car (s-expr s)) (s-temp-test)))
		  (not (equal (car (s-expr s)) (s-temp-fetch)))
		  (not (equal (car (s-expr s)) 'quote)))
	     (lr-check-result 'list
			      (s-ans (s-eval 'list
					     (s-set-pos s (dv (s-pos s) 1))
					     c))
			      (p-temp-stk lr-eval)
			      (p-data-segment lr-eval)
			      (p-temp-stk l))))
  ((disable lr-eval s-eval)
   (use (lr-eval-s-eval-equivalence
	 (s (s-set-pos s (dv (s-pos s) 1)))
	 (l l) (table table) (c c) (flag 'list)))))

(prove-lemma CADDDR-MAX-R (rewrite)
  (equal (cadddr (max-r list1 list2))
	 (plus (cadddr list1) (cadddr list2)))
  ((enable max-r)))

(prove-lemma LR-EVAL-S-EVAL-HEAP-R-LR-COUNT-LR-FREE-LIST-NODES ()
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(lr-proper-heapp (p-data-segment l))
		(good-posp flag (s-pos s) (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(lr-s-similar-statesp (s-params s)
				      (s-temps s)
				      (s->lr1 s l table)
				      table)
		(s-good-statep s c)
		(equal (p-psw (lr-eval flag (s->lr1 s l table) c)) 'run)
		(equal (s-err-flag (s-eval flag s c)) 'run))
	   (equal (plus (lr-count-free-nodes
			 (fetch (lr-fp-addr)
				(p-data-segment (lr-eval flag
							 (s->lr1 s l table)
							 c)))
			 (lr-free-list-nodes
			  (lr-max-node (p-data-segment l))
			  (p-data-segment (lr-eval flag
						   (s->lr1 s l table)
						   c)))
			 (p-data-segment (lr-eval flag
						  (s->lr1 s l table)
						  c)))
			(s-eval-heap-r flag s c))
		  (lr-count-free-nodes
		   (fetch (lr-fp-addr) (p-data-segment l))
		   (lr-free-list-nodes
		    (lr-max-node (p-data-segment l))
		    (p-data-segment l))
		   (p-data-segment l))))
  ((induct (ihint-2 flag s l table c))
   (enable s-eval-heap-r
	   p-psw-run-lr-if-ok-p-psw-run
	   lr-eval-if-p-psw-1)
   (expand (s-eval-r flag s c) (s-eval-r 'list s c) (s-eval-r flag s 0)
	   (s-eval flag s c) (s-eval 'list s c) (s-eval flag s 0))
   (disable definedp lr-compile-body lr-compile-programs lr-count-free-nodes
	    lr-eval lr-free-list-nodes lr-make-temp-name-alist s-eval
	    s-eval-r
	    good-posp1-cons-lessp-4-if-lr-proper-exprp
	    good-posp-list-nx-t-simple
	    formal-vars-lr-compile-programs
	    proper-p-statep-lr->p-strip-cars-bindings-ctrl-stk
	    s-eval-l-eval-flag-run-flag-t
	    s-eval-l-eval-flag-run-helper-5
	    s-eval-l-eval-flag-t
	    temp-var-dcls-lr-compile-programs)))

(prove-lemma LR-CHECK-RESOURCESP-LIST-SET-EXPR-NX (rewrite)
  (implies (and (listp (s-pos s))
		(listp (s-expr-list s))
		(good-posp 'list (s-pos s) (s-body (s-prog s)))
		(proper-p-statep (lr->p (s->lr1 s l table)))
		(lr-proper-heapp (p-data-segment l))
		(lr-programs-properp (s->lr1 s l table) table)
		(lr-s-similar-statesp (s-params s)
				      (s-temps s)
				      (s->lr1 s l table)
				      table)
		(s-good-statep s c)
		(equal (p-psw (lr-eval t (s->lr1 s l table) c)) 'run)
		(equal (s-err-flag (s-eval t s c)) 'run)
		(lr-check-resourcesp 'list s l c))
	   (lr-check-resourcesp 'list
				(s-set-expr (s-eval t s c)
					    s
					    (nx (s-pos s)))
				(lr-eval t (s->lr1 s l table) c)
				c))
  ((enable lr-check-resourcesp s-eval-ctrl-r s-eval-temp-r s-eval-ws-r
	   s-eval-heap-r)
   (expand (s-eval-r 'list s c))
   (use (lr-eval-s-eval-heap-r-lr-count-lr-free-list-nodes
	 (s s) (l l) (table table) (c c) (flag t)))
   (disable lr-compile-body lr-compile-programs lr-count-free-nodes lr-eval
	    lr-free-list-nodes lr-make-temp-name-alist p-ctrl-stk-size
	    s-eval s-eval-ctrl-r s-eval-heap-r s-eval-temp-r s-eval-ws-r
	    good-posp-list-nx-t-simple
	    lr-eval-s->lr1-quote-opener
	    lr-eval-s->lr1-temp-eval-opener
	    lr-eval-s->lr1-temp-fetch-opener
	    lr-eval-s->lr1-temp-test-opener
	    s-eval-l-eval-flag-run-flag-t)))

(prove-lemma LR-CHECK-RESOURCESP-LR-PUSH-TSTK-FLAG-RUN (rewrite)
  (implies (and (lr-check-resourcesp flag s l c)
		(not (equal flag 'list))
		(litatom (s-expr s))
		(not (zerop c))
		(equal (s-err-flag s) 'run))
	   (equal
	    (p-psw (lr-push-tstk (s->lr1 s l table)
				 (cdr (assoc (s-expr s)
					     (bindings
					      (car (p-ctrl-stk l)))))))
		  'run))
  ((enable lr-check-resourcesp lr-push-tstk s-eval-temp-r)))

(prove-lemma LR-CHECK-RESOURCESP-S-SET-POS-IF-CADR (rewrite)
  (implies (and (lr-check-resourcesp flag s l c)
		(s-good-statep s c)
		(not (equal flag 'list))
		(not (zerop c))
		(listp (s-expr s))
		(equal (car (s-expr s)) 'if))
	   (lr-check-resourcesp t (s-set-pos s (dv (s-pos s) 1)) l c))
  ((enable lr-check-resourcesp s-eval-ctrl-r s-eval-heap-r s-eval-temp-r
	   s-eval-ws-r)
   (expand (s-eval-r flag s c))
   (disable length lr-count-free-nodes lr-free-list-nodes p-ctrl-stk-size
	    s-eval
	    lr-check-resourcesp-listp-s-expr-list
	    good-posp1-cons-lessp-4-if-lr-proper-exprp
	    offset-lr-max-node
	    s-err-flag-s-eval-flag-list-flag-t
	    s-eval-l-eval-flag-t
	    s-eval-l-eval-flag-run-flag-t
	    s-proper-exprp-fact-2)))

(prove-lemma S-EVAL-SUBSETP-S-COLLECT-TEMP-ALIST-S-SET-POS-IF (rewrite)
  (implies (and (listp (s-expr s))
		(equal (car (s-expr s)) 'if)
		(s-good-statep s c)
		(good-posp1 (dv (s-pos s) 1) (s-body (s-prog s)))
		(s-check-temps-setp (s-temps s))
		(s-all-temps-setp t
				  (cadr (s-expr s))
				  (temp-alist-to-set (s-temps s)))
		(s-all-progs-temps-setp (s-progs s))
		(equal (s-err-flag (s-eval t
					   (s-set-pos s (dv (s-pos s) 1))
					   c))
		       'run))
	   (subsetp (s-collect-all-temps t (cadr (s-expr s)))
		    (temp-alist-to-set
		     (s-temps (s-eval t
				      (s-set-pos s (dv (s-pos s) 1))
				      c)))))
  ((use (s-eval-l-eval-flag-run
	 (s (s-set-pos s (dv (s-pos s) 1))) (flag t) (c c))
	(s-eval-l-eval-equivalence
	 (s (s-set-pos s (dv (s-pos s) 1))) (flag t) (c c)))
   (disable l-eval s-collect-all-temps s-eval
	    s-eval-temps-subsetp)))

(prove-lemma LENGTH-P-TEMP-STK-LR-POP-TSTK-LR-EVAL-FLAG-T (rewrite)
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(good-posp1 pos (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(s-good-statep s c)
		(equal (p-psw (lr-if-ok (lr-eval t
						 (lr-set-pos (s->lr1 s
								     l
								     table)
							     pos)
						 c)))
		       'run))
	   (equal (length (p-temp-stk (lr-pop-tstk
				       (lr-if-ok
					(lr-eval t
						 (lr-set-pos (s->lr1 s
								     l
								     table)
							     pos)
						 c)))))
		  (length (p-temp-stk l))))
  ((enable p-psw-run-lr-if-ok-p-psw-run)
   (use (length-p-temp-stk-lr-eval
	 (flag t) (l (lr-set-pos (s->lr1 s l table) pos)) (c c)))
   (expand (lr-compile-programs (s-progs s) table))
   (disable lr-compile-body lr-compile-programs lr-eval
	    lr-make-temp-name-alist)))

(prove-lemma LR-EVAL-S->LR1-PRESERVES-P-CTRL-STK-SIZE-LR-SET-POS (rewrite)
  (implies (and (proper-p-statep (lr->p l))
		(good-posp flag pos (program-body (p-current-program l)))
		(lr-programs-properp l table)
                (equal (p-psw (lr-eval flag (lr-set-pos l pos) c)) 'run))
           (equal (p-ctrl-stk-size (p-ctrl-stk (lr-eval flag
							(lr-set-pos l pos)
							c)))
                  (p-ctrl-stk-size (p-ctrl-stk l))))
  ((use (lr-eval-s->lr1-preserves-p-ctrl-stk-size
	 (l (lr-set-pos l pos)) (flag flag) (table table) (c c)))
   (disable lr-eval p-ctrl-stk-size
	    lr-eval-s->lr1-preserves-p-ctrl-stk-size)))

(prove-lemma LR-CHECK-RESOURCESP-LR-POP-TSTK-LR-EVAL-1 (rewrite)
  (let ((lr-eval (lr-if-ok (lr-eval t
				    (lr-set-pos (s->lr1 s l table) pos)
				    c))))
    (implies (and (not (zerop c))
		  (listp (s-expr s))
		  (equal (car (s-expr s)) 'if)
		  (proper-p-statep (lr->p (s->lr1 s l table)))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (lr-proper-heapp (p-data-segment l))
		  (lr-programs-properp (s->lr1 s l table) table)
		  (lr-s-similar-statesp (s-params s)
					(s-temps s)
					(s->lr1 s l table)
					table)
		  (s-good-statep s c)
		  (equal (p-psw lr-eval) 'run)
		  (equal pos (dv (s-pos s) 1))
		  (equal (s-err-flag (s-eval t (s-set-pos s pos) c)) 'run)
		  (s-ans (s-eval t (s-set-pos s (dv (s-pos s) 1)) c))
		  (lr-check-resourcesp flag s l c)
		  (not (equal flag 'list)))
	     (lr-check-resourcesp t
				  (s-set-expr (s-eval t (s-set-pos s pos) c)
					      s
					      (dv (s-pos s) 2))
				  (lr-pop-tstk lr-eval)
				  c)))
  ((enable lr-check-resourcesp s-eval-ctrl-r s-eval-heap-r s-eval-temp-r
	   s-eval-ws-r
	   p-psw-run-lr-if-ok-p-psw-run)
   (expand (s-eval-r flag s c))
   (use (lr-eval-s-eval-heap-r-lr-count-lr-free-list-nodes
	 (s (s-set-pos s (dv (s-pos s) 1)))
	 (flag t) (l l) (table table) (c c)))
   (disable length lr-compile-body lr-compile-programs lr-count-free-nodes
	    lr-make-temp-name-alist lr-eval lr-free-list-nodes s-eval
	    p-ctrl-stk-size
	    equal-plus-0 equal-length-0
	    good-posp1-cons-lessp-4-if-lr-proper-exprp
	    good-posp1-list-good-posp-list-t
	    good-posp1-nlistp
	    length-nlistp
	    lr-check-resourcesp-listp-s-expr-list
	    lr-eval-zerop-clock
	    lr-programs-properp-funcall-not-caar-prog-seg
	    lr-programs-properp-lr->p-s->lr1-definedp-s-pname
	    not-proper-p-statep-not-listp-p-ctrl-stk
	    offset-lr-max-node
	    p-temp-stk-lr-pop-tstk
	    plus-zero-arg2
	    s-err-flag-s-eval-flag-list-flag-t
	    s-eval-err-flag-not-run-fact
	    s-eval-l-eval-flag-t
	    s-eval-l-eval-flag-run-flag-t
	    s-proper-exprp-fact-2)))

(prove-lemma LR-CHECK-RESOURCESP-LR-POP-TSTK-LR-EVAL-2 (rewrite)
  (let ((lr-eval (lr-if-ok (lr-eval t
				    (lr-set-pos (s->lr1 s l table) pos)
				    c))))
    (implies (and (not (zerop c))
		  (listp (s-expr s))
		  (equal (car (s-expr s)) 'if)
		  (proper-p-statep (lr->p (s->lr1 s l table)))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (lr-proper-heapp (p-data-segment l))
		  (lr-programs-properp (s->lr1 s l table) table)
		  (lr-s-similar-statesp (s-params s)
					(s-temps s)
					(s->lr1 s l table)
					table)
		  (s-good-statep s c)
		  (equal (p-psw lr-eval) 'run)
		  (equal pos (dv (s-pos s) 1))
		  (equal (s-err-flag (s-eval t (s-set-pos s pos) c)) 'run)
		  (not (s-ans (s-eval t (s-set-pos s (dv (s-pos s) 1)) c)))
		  (lr-check-resourcesp flag s l c)
		  (not (equal flag 'list)))
	     (lr-check-resourcesp t
				  (s-set-expr (s-eval t (s-set-pos s pos) c)
					      s
					      (dv (s-pos s) 3))
				  (lr-pop-tstk lr-eval)
				  c)))
  ((enable lr-check-resourcesp s-eval-ctrl-r s-eval-heap-r s-eval-temp-r
	   s-eval-ws-r
	   p-psw-run-lr-if-ok-p-psw-run)
   (expand (s-eval-r flag s c))
   (use (lr-eval-s-eval-heap-r-lr-count-lr-free-list-nodes
	 (s (s-set-pos s (dv (s-pos s) 1)))
	 (flag t) (l l) (table table) (c c)))
   (disable length lr-compile-body lr-compile-programs lr-count-free-nodes
	    lr-make-temp-name-alist lr-eval lr-free-list-nodes s-eval
	    p-ctrl-stk-size
	    equal-plus-0 equal-length-0
	    good-posp1-cons-lessp-4-if-lr-proper-exprp
	    good-posp1-list-good-posp-list-t
	    good-posp1-nlistp
	    length-nlistp
	    lr-check-resourcesp-listp-s-expr-list
	    lr-eval-zerop-clock
	    lr-programs-properp-funcall-not-caar-prog-seg
	    lr-programs-properp-lr->p-s->lr1-definedp-s-pname
	    not-proper-p-statep-not-listp-p-ctrl-stk
	    offset-lr-max-node
	    p-temp-stk-lr-pop-tstk
	    plus-zero-arg2
	    s-err-flag-s-eval-flag-list-flag-t
	    s-eval-err-flag-not-run-fact
	    s-eval-l-eval-flag-t
	    s-eval-l-eval-flag-run-flag-t
	    s-proper-exprp-fact-2)))

(prove-lemma LR-CHECK-RESOURCESP-S-TEMP-EVAL (rewrite)
  (implies (and (not (zerop c))
		(listp (s-expr s))
		(equal (car (s-expr s)) (s-temp-eval))
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(equal pos (dv (s-pos s) 1))
		(lr-check-resourcesp flag s l c)
		(not (equal flag 'list)))
	     (lr-check-resourcesp t (s-set-pos s pos) l c))
  ((enable lr-check-resourcesp s-eval-ctrl-r s-eval-heap-r s-eval-temp-r
	   s-eval-ws-r)
   (expand (s-eval-r flag s c))
   (disable lr-free-list-nodes s-eval p-ctrl-stk-size)))

(prove-lemma LR-CHECK-RESOURCESP-S-TEMP-TEST (rewrite)
  (implies (and (not (zerop c))
		(listp (s-expr s))
		(equal (car (s-expr s)) (s-temp-test))
		(not (s-temp-setp (cadr (s-expr s)) (s-temps s)))
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(equal pos (dv (s-pos s) 1))
		(lr-check-resourcesp flag s l c)
		(not (equal flag 'list)))
	     (lr-check-resourcesp t (s-set-pos s pos) l c))
  ((enable lr-check-resourcesp s-eval-ctrl-r s-eval-heap-r s-eval-temp-r
	   s-eval-ws-r)
   (expand (s-eval-r flag s c))
   (disable lr-free-list-nodes p-ctrl-stk-size s-eval)))

(prove-lemma LR-DO-TEMP-FETCH-LR-CHECK-RESOURCESP-TEMP-TEST (rewrite)
  (implies (and (lr-check-resourcesp flag s l c)
		(proper-p-statep (lr->p (s->lr1 s l table)))
		(lr-proper-heapp (p-data-segment l))
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(listp (s-expr s))
		(or (equal (car (s-expr s)) (s-temp-test))
		    (equal (car (s-expr s)) (s-temp-fetch)))
		(s-good-statep s c)
		(lr-s-similar-statesp (s-params s)
				      (s-temps s)
				      (s->lr1 s l table)
				      table)
		(not (zerop c))
		(s-temp-setp (cadr (s-expr s)) (s-temps s))
		(not (equal flag 'list)))
	   (equal (p-psw (lr-do-temp-fetch (s->lr1 s l table))) 'run))
  ((enable lr-check-resourcesp lr-do-temp-fetch lr-push-tstk s-eval-temp-r)
   (disable lr-count-free-nodes
	    get-sub1-length-car-last
	    good-posp1-list-good-posp-list-t
	    good-posp1-cons-lessp-4-if-lr-proper-exprp
	    s-err-flag-s-eval-flag-list-flag-t
	    s-eval-l-eval-flag-t
	    s-eval-l-eval-flag-run-flag-t)
   (expand (s-eval-r flag s c))))

(prove-lemma LR-PUSH-TSTK-LR-CHECK-RESOURCESP-QUOTE (rewrite)
  (implies (and (lr-check-resourcesp flag s l c)
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(listp (s-expr s))
		(equal (car (s-expr s)) 'quote)
		(s-good-statep s c)
		(not (zerop c))
		(not (equal flag 'list)))
	   (equal (p-psw (lr-push-tstk (s->lr1 s l table)
				       (cadr (lr-expr (s->lr1 s l table)))))
		  'run))
  ((enable lr-check-resourcesp lr-do-temp-fetch lr-push-tstk s-eval-temp-r)
   (disable lr-count-free-nodes
	    get-sub1-length-car-last
	    good-posp1-list-good-posp-list-t
	    good-posp1-cons-lessp-4-if-lr-proper-exprp
	    s-err-flag-s-eval-flag-list-flag-t
	    s-eval-l-eval-flag-t
	    s-eval-l-eval-flag-run-flag-t)
   (expand (s-eval-r flag s c))))

(prove-lemma LR-CHECK-RESOURCESP-FUNCALL (rewrite)
  (implies (and (not (zerop c))
		(listp (s-expr s))
		(not (equal (car (s-expr s)) 'if))
		(not (equal (car (s-expr s)) (s-temp-eval)))
		(not (equal (car (s-expr s)) (s-temp-test)))
		(not (equal (car (s-expr s)) (s-temp-fetch)))
		(not (equal (car (s-expr s)) 'quote))
		(equal (s-err-flag (s-eval 'list
					   (s-set-pos s (dv (s-pos s) 1))
					   c))
		       'run)
		(proper-p-statep (lr->p (s->lr1 s l table)))
		(lr-proper-heapp (p-data-segment l))
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(s-good-statep s c)
		(lr-check-resourcesp flag s l c)
		(not (equal flag 'list)))
	   (lr-check-resourcesp 'list (s-set-pos s (dv (s-pos s) 1)) l c))
  ((enable lr-check-resourcesp s-eval-ctrl-r s-eval-heap-r s-eval-temp-r
	   s-eval-ws-r)
   (disable lr-count-free-nodes s-eval s-eval-r
	    good-posp-list-nx-t-simple
	    good-posp1-list-good-posp-list-t
	    good-posp1-cons-lessp-4-if-lr-proper-exprp
	    s-eval-err-flag-not-run-fact
	    s-eval-l-eval-flag-t
	    s-eval-l-eval-flag-run-flag-t)
   (expand (s-eval-r flag s c))))

(prove-lemma NUMBERP-S-EVAL-TEMP-CTRL-WS-HEAP-R-OPENED (rewrite)
  (and (numberp (car (s-eval-r flag s c)))
       (numberp (cadr (s-eval-r flag s c)))
       (numberp (caddr (s-eval-r flag s c)))
       (numberp (cadddr (s-eval-r flag s c))))
  ((use (numberp-s-eval-temp-ctrl-ws-heap-r (flag flag) (s s) (c c)))
   (enable s-eval-temp-r s-eval-ctrl-r s-eval-ws-r s-eval-heap-r)
   (disable s-eval-r
	    numberp-s-eval-temp-ctrl-ws-heap-r)))

(prove-lemma LESSP-1-NOT-ZEROP-EXP (rewrite)
  (implies (and (not (zerop m))
		(lessp 1 n))
	   (lessp 1 (exp n m))))

(prove-lemma LESSP-1-NOT-ZEROP-LOG (rewrite)
  (implies (and (lessp 1 c)
		(numberp n))
	   (equal (lessp (log c n) 1) (lessp n 1))))

(defn INDUCT-HINT-18 (c n m)
  (cond ((lessp c 2) t)
	((zerop n) t)
	((zerop m) t)
	(t (induct-hint-18 c (quotient n c) (sub1 m)))))

(prove-lemma TIMES-QUOTIENT-LESSP-FACT-1 (rewrite)
  (implies (and (not (zerop c))
		(numberp n)
		(numberp m))
	   (equal (lessp n (times c m))
		  (lessp (quotient n c) m))))

(prove-lemma EXP-LOG-LESSP-FACT-1 ()
  (implies (and (lessp 1 c)
		(numberp n)
		(numberp m))
	   (equal (lessp n (exp c m))
		  (lessp (log c n) (add1 m))))
  ((induct (induct-hint-18 c n m))
   (disable log-quotient)))

(disable times-quotient-lessp-fact-1)

(prove-lemma ADPP-UNTAG-ADD-ADDR-OFFSET-CAR (rewrite)
 (implies (and (lr-good-pointerp addr data-seg)
	       (lr-proper-p-areasp data-seg)
	       (equal (untag (fetch addr data-seg)) (lr-cons-tag))
	       (lr-proper-heapp data-seg))
          (adpp (untag (add-addr addr (identity (lr-car-offset))))
		data-seg))
 ((disable lr-proper-heapp2)
  (enable fetch-lr-nodep-add-addr)
  (use (lr-nodep-lr-proper-heapp-nodep
	(max-addr (lr-max-node data-seg))
	(addr addr)
	(data-seg data-seg))
       (lr-proper-heapp-nodep-tag-cons (addr addr)
				       (data-seg data-seg)
				       (offset (lr-car-offset))))))

(prove-lemma ADPP-UNTAG-ADD-ADDR-OFFSET-CDR (rewrite)
 (implies (and (lr-good-pointerp addr data-seg)
	       (lr-proper-p-areasp data-seg)
	       (equal (untag (fetch addr data-seg)) (lr-cons-tag))
	       (lr-proper-heapp data-seg))
          (adpp (untag (add-addr addr (identity (lr-cdr-offset))))
		data-seg))
 ((disable lr-proper-heapp2)
  (enable fetch-lr-nodep-add-addr
	  lr-minimum-heapp-opener-2)
  (use (lr-nodep-lr-proper-heapp-nodep
	(max-addr (lr-max-node data-seg))
	(addr addr)
	(data-seg data-seg))
       (lr-proper-heapp-nodep-tag-cons (addr addr)
				       (data-seg data-seg)
				       (offset (lr-cdr-offset))))))

(prove-lemma EXP-LOG-2-LESSP-ADD1-FACT-1 (rewrite)
  (equal (lessp (add1 n) (exp 2 m))
	 (lessp (log 2 (add1 n)) (add1 m)))
  ((use (exp-log-lessp-fact-1 (n (add1 n)) (c 2) (m m)))))

;; The P-TEST-BOOL-AND-JUMP cause a lot of case splits after being opened
;; and the result rewritten with P-OBJECTP-TYPE, so we prove two simple
;; lemmas and disable it, this should hopefully speed up the proof.
(prove-lemma P-TEST-BOOL-AND-JUMP-OKP-T-CONS-BOOL-T (rewrite)
  (equal (p-test-bool-and-jump-okp (list ins-name 't label)
				   (p-state pc
					    ctrl-stk
					    (cons '(bool t) temp-stk)
					    prog-seg
					    data-seg
					    max-ctrl
					    max-temp
					    word-size
					    psw))
	 t)
  ((disable p-ins-okp-backchainer)))

(prove-lemma P-TEST-BOOL-AND-JUMP-OKP-F-CONS-BOOL-T (rewrite)
  (equal (p-test-bool-and-jump-okp (list ins-name 'f label)
				   (p-state pc
					    ctrl-stk
					    (cons '(bool t) temp-stk)
					    prog-seg
					    data-seg
					    max-ctrl
					    max-temp
					    word-size
					    psw))
	 t)
  ((disable p-ins-okp-backchainer)))

(prove-lemma P-TEST-BOOL-AND-JUMP-OKP-T-CONS-BOOL-F (rewrite)
  (equal (p-test-bool-and-jump-okp (list ins-name 't label)
				   (p-state pc
					    ctrl-stk
					    (cons '(bool f) temp-stk)
					    prog-seg
					    data-seg
					    max-ctrl
					    max-temp
					    word-size
					    psw))
	 t)
  ((disable p-ins-okp-backchainer)))

(prove-lemma P-TEST-BOOL-AND-JUMP-OKP-F-CONS-BOOL-F (rewrite)
  (equal (p-test-bool-and-jump-okp (list ins-name 'f label)
				   (p-state pc
					    ctrl-stk
					    (cons '(bool f) temp-stk)
					    prog-seg
					    data-seg
					    max-ctrl
					    max-temp
					    word-size
					    psw))
	 t)
  ((disable p-ins-okp-backchainer)))

(disable p-test-bool-and-jump-okp)

(prove-lemma P-PSW-RUN-RUN-CAR-LR-CHECK-RESOURCESP (rewrite)
  (implies (and (lr-check-result 'list
				 (s-ans new-s)
				 (p-temp-stk new-l)
				 (p-data-segment new-l)
				 orig-temp-stk)
		(proper-p-statep (lr->p new-l))
		(equal (p-psw new-l) 'run)
		(lr-programs-properp new-l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p new-l))))))
		       '(call car))
		(not (lessp (p-max-temp-stk-size new-l)
			    (plus (length (p-temp-stk new-l))
				  (car (s-apply-subr-r 'car new-s)))))
		(not (lessp (p-max-ctrl-stk-size new-l)
			    (plus (p-ctrl-stk-size (p-ctrl-stk new-l))
				  (cadr (s-apply-subr-r 'car new-s)))))
		(not (lessp (p-word-size new-l)
			    (max (s-max-subr-reqs)
				 (caddr (s-apply-subr-r 'car new-s)))))
		(not (lessp (lr-count-free-nodes
			     (fetch (lr-fp-addr) (p-data-segment new-l))
			     (lr-free-list-nodes (lr-max-node
						  (p-data-segment new-l))
						 (p-data-segment new-l))
			     (p-data-segment new-l))
			    (cadddr (s-apply-subr-r 'car new-s))))
		(not (lessp (length (p-temp-stk new-l)) (arity 'car)))
		(equal (length (s-ans new-s)) (arity 'car)))
	   (equal (p-psw (p (p-set-pc (lr->p new-l) pc)
			    (p-car-clock (p-set-pc (lr->p new-l) pc))))
		  'run))
  ((disable lr-count-free-nodes lr-free-list-nodes lr-check-result1 lr-valp
	    *1*x-y-error-msg
	    lr-check-result1-first-n-temp-stk)
   (disable-theory addition)
   (enable lr-check-result lr-good-pointerp p-car-clock p-set-pc
	   s-apply-subr-r
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   proper-p-statep-bad-type-1
	   p-opener p-psw-p-halt-x-y-error-msg p-step1-opener)))

(prove-lemma P-PSW-RUN-RUN-CDR-LR-CHECK-RESOURCESP (rewrite)
  (implies (and (lr-check-result 'list
				 (s-ans new-s)
				 (p-temp-stk new-l)
				 (p-data-segment new-l)
				 orig-temp-stk)
		(proper-p-statep (lr->p new-l))
		(equal (p-psw new-l) 'run)
		(lr-programs-properp new-l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p new-l))))))
		       '(call cdr))
		(not (lessp (p-max-temp-stk-size new-l)
			    (plus (length (p-temp-stk new-l))
				  (car (s-apply-subr-r 'cdr new-s)))))
		(not (lessp (p-max-ctrl-stk-size new-l)
			    (plus (p-ctrl-stk-size (p-ctrl-stk new-l))
				  (cadr (s-apply-subr-r 'cdr new-s)))))
		(not (lessp (p-word-size new-l)
			    (max (s-max-subr-reqs)
				 (caddr (s-apply-subr-r 'cdr new-s)))))
		(not (lessp (lr-count-free-nodes
			     (fetch (lr-fp-addr) (p-data-segment new-l))
			     (lr-free-list-nodes (lr-max-node
						  (p-data-segment new-l))
						 (p-data-segment new-l))
			     (p-data-segment new-l))
			    (cadddr (s-apply-subr-r 'cdr new-s))))
		(not (lessp (length (p-temp-stk new-l)) (arity 'cdr)))
		(equal (length (s-ans new-s)) (arity 'cdr)))
	   (equal (p-psw (p (p-set-pc (lr->p new-l) pc)
			    (p-cdr-clock (p-set-pc (lr->p new-l) pc))))
		  'run))
  ((disable lr-count-free-nodes lr-free-list-nodes lr-check-result1 lr-valp
	    *1*x-y-error-msg
	    lr-check-result1-first-n-temp-stk)
   (disable-theory addition)
   (enable lr-check-result lr-good-pointerp p-cdr-clock p-set-pc
	   s-apply-subr-r
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   proper-p-statep-bad-type-1
	   p-opener p-psw-p-halt-x-y-error-msg p-step1-opener)))

(prove-lemma LESSP-PLUS-REMAINDER-0-FACT ()
  (implies (and (equal (remainder offset1 max) 0)
		(equal (remainder offset2 max) 0)
		(lessp n max)
		(numberp offset1)
		(numberp offset2))
	   (equal (lessp (plus n offset1) offset2)
		  (lessp offset1 offset2)))
  ((disable difference-difference-arg1
	    equal-plus-0
	    equal-sub1-0
	    remainder-difference1
	    remainder-difference2)
   (induct (double-remainder-induction offset1 offset2 max))))

(prove-lemma LR-BOUNDARY-NODEP-LESSP-PLUS-FACT ()
  (implies (and (lr-boundary-nodep addr1)
		(lr-boundary-nodep addr2)
		(lessp n (lr-node-size))
		(numberp (offset addr1))
		(numberp (offset addr2)))
	   (equal (lessp (plus n (offset addr1)) (offset addr2))
		  (lessp (offset addr1) (offset addr2))))
  ((enable lr-boundary-nodep)
   (disable-theory addition quotients)
   (use (lessp-plus-remainder-0-fact (offset1 (offset addr1))
				     (offset2 (offset addr2))
				     (max (lr-node-size))
				     (n n)))))

(prove-lemma ADPP-UNTAG-ADD-ADDR-LR-NODEP-NOT-MAX-ADDR (rewrite)
  (implies (and (adpp (untag addr) data-seg)
		(lr-boundary-nodep addr)
		(equal (area-name addr) 'heap)
		(definedp (lr-heap-name) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg))
		(lessp (offset addr)
		       (offset (lr-max-node data-seg)))
		(lessp n (lr-node-size)))
	   (adpp (untag (add-addr addr n)) data-seg))
  ((enable adpp area-name lr-max-node offset)
   (use (lr-boundary-nodep-lessp-plus-fact
	 (addr1 addr)
	 (addr2 (lr-max-node data-seg))
	 (n n)))))

(prove-lemma ADPP-UNTAG-ADD-ADDR-OFFSET-ON-FREE-LISTP (rewrite)
  (implies (and (lr-proper-p-areasp data-seg)
		(not (lessp (lr-count-free-nodes
			     (fetch (lr-fp-addr) data-seg)
			     (lr-free-list-nodes
			      (lr-max-node data-seg)
			      data-seg)
			     data-seg)
			    1))
		(lr-proper-heapp data-seg)
		(lessp n (lr-node-size)))
	   (adpp (untag (add-addr (fetch (identity (lr-fp-addr))
					 data-seg)
				  n))
		 data-seg))
  ((enable lr-proper-free-listp
	   fetch-lr-nodep-add-addr
	   lr-node-listp-delete
	   lr-minimum-heapp-opener-3)
   (use (lr-free-list-nodes-member-greater-offset
	 (addr (fetch (lr-fp-addr) data-seg))
	 (max-addr (lr-max-node data-seg))
	 (data-seg data-seg)))
   (expand (lr-check-free-nodes (fetch (identity (lr-fp-addr)) data-seg)
				(lr-free-list-nodes (lr-max-node data-seg)
						    data-seg)
				data-seg
				(lr-max-node data-seg)))
   (disable lr-check-free-nodes lr-free-list-nodes
	    not-adpp-untag-add-addr-adpp-untag)))

(prove-lemma P-PSW-RUN-RUN-CONS-LR-CHECK-RESOURCESP (rewrite)
  (implies (and (lr-check-result 'list
				 (s-ans new-s)
				 (p-temp-stk new-l)
				 (p-data-segment new-l)
				 orig-temp-stk)
		(proper-p-statep (lr->p new-l))
		(equal (p-psw new-l) 'run)
		(lr-programs-properp new-l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p new-l))))))
		       '(call cons))
		(not (lessp (p-max-temp-stk-size new-l)
			    (plus (length (p-temp-stk new-l))
				  (car (s-apply-subr-r 'cons new-s)))))
		(not (lessp (p-max-ctrl-stk-size new-l)
			    (plus (p-ctrl-stk-size (p-ctrl-stk new-l))
				  (cadr (s-apply-subr-r 'cons new-s)))))
		(not (lessp (p-word-size new-l)
			    (max (s-max-subr-reqs)
				 (caddr (s-apply-subr-r 'cons new-s)))))
		(not (lessp (lr-count-free-nodes
			     (fetch (lr-fp-addr) (p-data-segment new-l))
			     (lr-free-list-nodes (lr-max-node
						  (p-data-segment new-l))
						 (p-data-segment new-l))
			     (p-data-segment new-l))
			    (cadddr (s-apply-subr-r 'cons new-s))))
		(not (lessp (length (p-temp-stk new-l)) (arity 'cons)))
		(equal (length (s-ans new-s)) (arity 'cons)))
	   (equal (p-psw (p (p-set-pc (lr->p new-l) pc)
			    (p-cons-clock (p-set-pc (lr->p new-l) pc))))
		  'run))
  ((disable lr-count-free-nodes lr-free-list-nodes lr-check-result1 lr-valp
	    *1*x-y-error-msg
	    lr-check-result1-first-n-temp-stk)
   (disable-theory addition)
   (enable lr-check-result lr-good-pointerp p-cons-clock p-set-pc
	   s-apply-subr-r
	   adpp-deposit-anything-at-all
	   definitions-subrps-lr-programs-properp
	   lr-minimum-heapp-opener-3
	   p-current-instruction-opener
	   p-opener p-psw-p-halt-x-y-error-msg p-step1-opener)))

(prove-lemma P-PSW-RUN-RUN-FALSE-LR-CHECK-RESOURCESP (rewrite)
  (implies (and (lr-check-result 'list
				 (s-ans new-s)
				 (p-temp-stk new-l)
				 (p-data-segment new-l)
				 orig-temp-stk)
		(proper-p-statep (lr->p new-l))
		(equal (p-psw new-l) 'run)
		(lr-programs-properp new-l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p new-l))))))
		       '(call false))
		(not (lessp (p-max-temp-stk-size new-l)
			    (plus (length (p-temp-stk new-l))
				  (car (s-apply-subr-r 'false new-s)))))
		(not (lessp (p-max-ctrl-stk-size new-l)
			    (plus (p-ctrl-stk-size (p-ctrl-stk new-l))
				  (cadr (s-apply-subr-r 'false new-s)))))
		(not (lessp (p-word-size new-l)
			    (max (s-max-subr-reqs)
				 (caddr (s-apply-subr-r 'false new-s)))))
		(not (lessp (lr-count-free-nodes
			     (fetch (lr-fp-addr) (p-data-segment new-l))
			     (lr-free-list-nodes (lr-max-node
						  (p-data-segment new-l))
						 (p-data-segment new-l))
			     (p-data-segment new-l))
			    (cadddr (s-apply-subr-r 'false new-s))))
		(not (lessp (length (p-temp-stk new-l)) (arity 'false)))
		(equal (length (s-ans new-s)) (arity 'false)))
	   (equal (p-psw (p (p-set-pc (lr->p new-l) pc)
			    (p-false-clock (p-set-pc (lr->p new-l) pc))))
		  'run))
  ((disable lr-count-free-nodes lr-free-list-nodes lr-check-result1 lr-valp
	    *1*x-y-error-msg
	    lr-check-result1-first-n-temp-stk)
   (disable-theory addition)
   (enable lr-check-result lr-good-pointerp p-false-clock p-set-pc
	   s-apply-subr-r
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   p-opener p-psw-p-halt-x-y-error-msg p-step1-opener)))

(prove-lemma P-PSW-RUN-RUN-FALSEP-LR-CHECK-RESOURCESP (rewrite)
  (implies (and (lr-check-result 'list
				 (s-ans new-s)
				 (p-temp-stk new-l)
				 (p-data-segment new-l)
				 orig-temp-stk)
		(proper-p-statep (lr->p new-l))
		(equal (p-psw new-l) 'run)
		(lr-programs-properp new-l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p new-l))))))
		       '(call falsep))
		(not (lessp (p-max-temp-stk-size new-l)
			    (plus (length (p-temp-stk new-l))
				  (car (s-apply-subr-r 'falsep new-s)))))
		(not (lessp (p-max-ctrl-stk-size new-l)
			    (plus (p-ctrl-stk-size (p-ctrl-stk new-l))
				  (cadr (s-apply-subr-r 'falsep new-s)))))
		(not (lessp (p-word-size new-l)
			    (max (s-max-subr-reqs)
				 (caddr (s-apply-subr-r 'falsep new-s)))))
		(not (lessp (lr-count-free-nodes
			     (fetch (lr-fp-addr) (p-data-segment new-l))
			     (lr-free-list-nodes (lr-max-node
						  (p-data-segment new-l))
						 (p-data-segment new-l))
			     (p-data-segment new-l))
			    (cadddr (s-apply-subr-r 'falsep new-s))))
		(not (lessp (length (p-temp-stk new-l)) (arity 'falsep)))
		(equal (length (s-ans new-s)) (arity 'falsep)))
	   (equal (p-psw (p (p-set-pc (lr->p new-l) pc)
			    (p-falsep-clock (p-set-pc (lr->p new-l) pc))))
		  'run))
  ((disable lr-count-free-nodes lr-free-list-nodes lr-check-result1 lr-valp
	    *1*x-y-error-msg
	    lr-check-result1-first-n-temp-stk)
   (disable-theory addition)
   (enable lr-check-result lr-good-pointerp p-falsep-clock p-set-pc
	   s-apply-subr-r
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   proper-p-statep-bad-type-2
	   p-opener p-psw-p-halt-x-y-error-msg p-step1-opener)))

(prove-lemma P-PSW-RUN-RUN-LISTP-LR-CHECK-RESOURCESP (rewrite)
  (implies (and (lr-check-result 'list
				 (s-ans new-s)
				 (p-temp-stk new-l)
				 (p-data-segment new-l)
				 orig-temp-stk)
		(proper-p-statep (lr->p new-l))
		(equal (p-psw new-l) 'run)
		(lr-programs-properp new-l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p new-l))))))
		       '(call listp))
		(not (lessp (p-max-temp-stk-size new-l)
			    (plus (length (p-temp-stk new-l))
				  (car (s-apply-subr-r 'listp new-s)))))
		(not (lessp (p-max-ctrl-stk-size new-l)
			    (plus (p-ctrl-stk-size (p-ctrl-stk new-l))
				  (cadr (s-apply-subr-r 'listp new-s)))))
		(not (lessp (p-word-size new-l)
			    (max (s-max-subr-reqs)
				 (caddr (s-apply-subr-r 'listp new-s)))))
		(not (lessp (lr-count-free-nodes
			     (fetch (lr-fp-addr) (p-data-segment new-l))
			     (lr-free-list-nodes (lr-max-node
						  (p-data-segment new-l))
						 (p-data-segment new-l))
			     (p-data-segment new-l))
			    (cadddr (s-apply-subr-r 'listp new-s))))
		(not (lessp (length (p-temp-stk new-l)) (arity 'listp)))
		(equal (length (s-ans new-s)) (arity 'listp)))
	   (equal (p-psw (p (p-set-pc (lr->p new-l) pc)
			    (p-listp-clock (p-set-pc (lr->p new-l) pc))))
		  'run))
  ((disable lr-count-free-nodes lr-free-list-nodes lr-check-result1 lr-valp
	    *1*x-y-error-msg
	    lr-check-result1-first-n-temp-stk)
   (disable-theory addition)
   (enable lr-check-result lr-good-pointerp p-listp-clock p-set-pc
	   s-apply-subr-r
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   proper-p-statep-bad-type-1
	   p-opener p-psw-p-halt-x-y-error-msg p-step1-opener)))

(prove-lemma P-PSW-RUN-RUN-NLISTP-LR-CHECK-RESOURCESP (rewrite)
  (implies (and (lr-check-result 'list
				 (s-ans new-s)
				 (p-temp-stk new-l)
				 (p-data-segment new-l)
				 orig-temp-stk)
		(proper-p-statep (lr->p new-l))
		(equal (p-psw new-l) 'run)
		(lr-programs-properp new-l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p new-l))))))
		       '(call nlistp))
		(not (lessp (p-max-temp-stk-size new-l)
			    (plus (length (p-temp-stk new-l))
				  (car (s-apply-subr-r 'nlistp new-s)))))
		(not (lessp (p-max-ctrl-stk-size new-l)
			    (plus (p-ctrl-stk-size (p-ctrl-stk new-l))
				  (cadr (s-apply-subr-r 'nlistp new-s)))))
		(not (lessp (p-word-size new-l)
			    (max (s-max-subr-reqs)
				 (caddr (s-apply-subr-r 'nlistp new-s)))))
		(not (lessp (lr-count-free-nodes
			     (fetch (lr-fp-addr) (p-data-segment new-l))
			     (lr-free-list-nodes (lr-max-node
						  (p-data-segment new-l))
						 (p-data-segment new-l))
			     (p-data-segment new-l))
			    (cadddr (s-apply-subr-r 'nlistp new-s))))
		(not (lessp (length (p-temp-stk new-l)) (arity 'nlistp)))
		(equal (length (s-ans new-s)) (arity 'nlistp)))
	   (equal (p-psw (p (p-set-pc (lr->p new-l) pc)
			    (p-nlistp-clock (p-set-pc (lr->p new-l) pc))))
		  'run))
  ((disable lr-count-free-nodes lr-free-list-nodes lr-check-result1 lr-valp
	    *1*x-y-error-msg
	    lr-check-result1-first-n-temp-stk)
   (disable-theory addition)
   (enable lr-check-result lr-good-pointerp p-nlistp-clock p-set-pc
	   s-apply-subr-r
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   proper-p-statep-bad-type-1
	   p-opener p-psw-p-halt-x-y-error-msg p-step1-opener)))

(prove-lemma P-PSW-RUN-RUN-TRUE-LR-CHECK-RESOURCESP (rewrite)
  (implies (and (lr-check-result 'list
				 (s-ans new-s)
				 (p-temp-stk new-l)
				 (p-data-segment new-l)
				 orig-temp-stk)
		(proper-p-statep (lr->p new-l))
		(equal (p-psw new-l) 'run)
		(lr-programs-properp new-l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p new-l))))))
		       '(call true))
		(not (lessp (p-max-temp-stk-size new-l)
			    (plus (length (p-temp-stk new-l))
				  (car (s-apply-subr-r 'true new-s)))))
		(not (lessp (p-max-ctrl-stk-size new-l)
			    (plus (p-ctrl-stk-size (p-ctrl-stk new-l))
				  (cadr (s-apply-subr-r 'true new-s)))))
		(not (lessp (p-word-size new-l)
			    (max (s-max-subr-reqs)
				 (caddr (s-apply-subr-r 'true new-s)))))
		(not (lessp (lr-count-free-nodes
			     (fetch (lr-fp-addr) (p-data-segment new-l))
			     (lr-free-list-nodes (lr-max-node
						  (p-data-segment new-l))
						 (p-data-segment new-l))
			     (p-data-segment new-l))
			    (cadddr (s-apply-subr-r 'true new-s))))
		(not (lessp (length (p-temp-stk new-l)) (arity 'true)))
		(equal (length (s-ans new-s)) (arity 'true)))
	   (equal (p-psw (p (p-set-pc (lr->p new-l) pc)
			    (p-true-clock (p-set-pc (lr->p new-l) pc))))
		  'run))
  ((disable lr-count-free-nodes lr-free-list-nodes lr-check-result1 lr-valp
	    *1*x-y-error-msg
	    lr-check-result1-first-n-temp-stk)
   (disable-theory addition)
   (enable lr-check-result lr-good-pointerp p-true-clock p-set-pc
	   s-apply-subr-r
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   p-opener p-psw-p-halt-x-y-error-msg p-step1-opener)))

(prove-lemma P-PSW-RUN-RUN-TRUEP-LR-CHECK-RESOURCESP (rewrite)
  (implies (and (lr-check-result 'list
				 (s-ans new-s)
				 (p-temp-stk new-l)
				 (p-data-segment new-l)
				 orig-temp-stk)
		(proper-p-statep (lr->p new-l))
		(equal (p-psw new-l) 'run)
		(lr-programs-properp new-l table)
		(equal (unlabel
			(get (offset pc)
			     (program-body
			      (assoc (area-name pc)
				     (p-prog-segment (lr->p new-l))))))
		       '(call truep))
		(not (lessp (p-max-temp-stk-size new-l)
			    (plus (length (p-temp-stk new-l))
				  (car (s-apply-subr-r 'truep new-s)))))
		(not (lessp (p-max-ctrl-stk-size new-l)
			    (plus (p-ctrl-stk-size (p-ctrl-stk new-l))
				  (cadr (s-apply-subr-r 'truep new-s)))))
		(not (lessp (p-word-size new-l)
			    (max (s-max-subr-reqs)
				 (caddr (s-apply-subr-r 'truep new-s)))))
		(not (lessp (lr-count-free-nodes
			     (fetch (lr-fp-addr) (p-data-segment new-l))
			     (lr-free-list-nodes (lr-max-node
						  (p-data-segment new-l))
						 (p-data-segment new-l))
			     (p-data-segment new-l))
			    (cadddr (s-apply-subr-r 'truep new-s))))
		(not (lessp (length (p-temp-stk new-l)) (arity 'truep)))
		(equal (length (s-ans new-s)) (arity 'truep)))
	   (equal (p-psw (p (p-set-pc (lr->p new-l) pc)
			    (p-truep-clock (p-set-pc (lr->p new-l) pc))))
		  'run))
  ((disable lr-count-free-nodes lr-free-list-nodes lr-check-result1 lr-valp
	    *1*x-y-error-msg
	    lr-check-result1-first-n-temp-stk)
   (disable-theory addition)
   (enable lr-check-result lr-good-pointerp p-truep-clock p-set-pc
	   s-apply-subr-r
	   definitions-subrps-lr-programs-properp
	   p-current-instruction-opener
	   proper-p-statep-bad-type-1
	   p-opener p-psw-p-halt-x-y-error-msg p-step1-opener)))

(prove-lemma LENGTH-LAST (rewrite)
  (implies (listp l)
	   (equal (length (last l)) 1)))

(prove-lemma EQUAL-PLUS-LESSP-FACT (rewrite)
  (implies (equal (plus x z) y)
	   (equal (lessp y (plus n x)) (lessp z n))))

(prove-lemma NOT-LESSP-LR-COUNT-FREE-NODES-LR-EVAL-LIST-LR-SET-POS (rewrite)
  (let ((new-l (lr-eval 'list (lr-set-pos (s->lr1 s l table) pos) c)))
    (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		  (lr-proper-heapp (p-data-segment l))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (lr-programs-properp (s->lr1 s l table) table)
		  (lr-s-similar-statesp (s-params s)
					(s-temps s)
					(s->lr1 s l table)
					table)
		  (s-good-statep s c)
		  (equal (p-psw new-l) 'run)
		  (equal (s-err-flag (s-eval 'list
					     (s-set-pos s pos)
					     c))
			 'run)
		  (listp (s-expr s))
		  (not (equal (car (s-expr s)) 'if))
		  (not (equal (car (s-expr s)) (s-temp-eval)))
		  (not (equal (car (s-expr s)) (s-temp-test)))
		  (not (equal (car (s-expr s)) (s-temp-fetch)))
		  (not (equal (car (s-expr s)) 'quote))
		  (equal pos (dv (s-pos s) 1))
		  (equal max-addr (lr-max-node (p-data-segment l))))
	     (equal (lessp (lr-count-free-nodes
			    (fetch (identity (lr-fp-addr))
				   (p-data-segment new-l))
			    (lr-free-list-nodes
			     max-addr
			     (p-data-segment new-l))
			    (p-data-segment new-l))
			   n)
		    (lessp (lr-count-free-nodes
			    (fetch (identity (lr-fp-addr))
				   (p-data-segment l))
			    (lr-free-list-nodes
			     max-addr
			     (p-data-segment l))
			    (p-data-segment l))
			   (plus (s-eval-heap-r 'list
						(s-set-pos s
							   (dv (s-pos s) 1))
						c)
				 n)))))
  ((use (lr-eval-s-eval-heap-r-lr-count-lr-free-list-nodes
	 (s (s-set-pos s (dv (s-pos s) 1)))
	 (flag 'list) (l l) (table table) (c c)))
   (disable lr-eval s-eval s-eval-r)))

(disable equal-plus-lessp-fact)

(prove-lemma LR-PROGRAMS-PROPERP-DEFINEDP-SUBRP-RUNTIME-SUPPORT (rewrite)
  (implies (and (not (definedp (car (lr-expr l))
			       (p-runtime-support-programs)))
		(not (equal (car (lr-expr l)) 'if))
		(subrp (car (lr-expr l)))
		(good-posp1 (offset (p-pc l))
			    (program-body (p-current-program l))))
	   (not (lr-programs-properp l table)))
  ((use (lr-programs-properp-lr-proper-exprp-lr-expr (l l) (table table)))
   (expand
    (lr-proper-exprp t
		     (lr-expr l)
		     (strip-logic-fnames (cdr (p-prog-segment l)))
		     (formal-vars (p-current-program l))
		     (strip-cars (temp-var-dcls (p-current-program l)))
		     table))))

(prove-lemma P-PSW-RUN-P-RUN-SUBR-LR-CHECK-RESOURCESP (rewrite)
  (let ((new-l (lr-eval 'list (lr-set-pos (s->lr1 s l table) pos) c))
	(new-s (s-eval 'list (s-set-pos s pos) c))
	(pc (lr-return-pc (s->lr1 s l table)))
	(r (s-apply-subr-r (car (s-expr s))
			   (s-eval 'list (s-set-pos s pos) c))))
    (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		  (not (zerop c))
		  (listp (s-expr s))
		  (not (equal (car (s-expr s)) 'if))
		  (not (equal (car (s-expr s)) 'quote))
		  (equal (s-err-flag new-s) 'run)
		  (subrp (car (s-expr s)))
		  (equal (p-psw new-l) 'run)
		  (lr-proper-heapp (p-data-segment l))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (lr-programs-properp (s->lr1 s l table) table)
		  (lr-s-similar-statesp (s-params s)
					(s-temps s)
					(s->lr1 s l table)
					table)
		  (s-good-statep s c)
		  (not (lessp (p-max-temp-stk-size l)
			      (plus (length (p-temp-stk l))
				    (arity (car (s-expr s)))
				    (car r))))
		  (not (lessp (p-max-ctrl-stk-size l)
			      (plus (p-ctrl-stk-size (p-ctrl-stk l))
				    (cadr r))))
		  (not (lessp (p-word-size l)
			      (max (s-max-subr-reqs) (caddr r))))
		  (not (lessp (lr-count-free-nodes
			       (fetch (lr-fp-addr) (p-data-segment l))
			       (lr-free-list-nodes (lr-max-node
						    (p-data-segment l))
						   (p-data-segment l))
			       (p-data-segment l))
			      (plus (cadddr r)
				    (s-eval-heap-r 'list
						   (s-set-pos s pos)
						   c))))
		  (equal pos (dv (s-pos s) 1)))
	     (equal (p-psw (p-run-subr (car (s-expr s))
				       (p-set-pc (lr->p new-l) pc)))
		    'run)))
  ((enable p-run-subr)
   (use (lr-eval-s-eval-equivalence-lr-check-result-flag-list
	 (s s) (l l) (table table) (c c))
	(lr-programs-properp-lr-eval
	 (flag 'list) (l (lr-set-pos (s->lr1 s l table) pos))
	 (c c) (table table)))
   (disable lr-compile-body lr-compile-programs lr-count-free-nodes lr-eval
	    lr-free-list-nodes lr-make-temp-name-alist p-ctrl-stk-size
	    s-eval s-eval-r
	    equal-plus-0 equal-length-0
	    good-posp1-nlistp good-posp1-list-good-posp-list-t
	    length-nlistp
	    lr-eval-s-eval-equivalence-lr-check-result-flag-list
	    lr-eval-zerop-clock
	    lr-programs-properp-funcall-not-caar-prog-seg
	    lr-programs-properp-lr->p-s->lr1-definedp-s-pname
	    lr-programs-properp-lr-eval
	    not-iff-lr-s-temp-setp-not-lr-s-similar-statesp
	    not-proper-p-statep-not-listp-p-ctrl-stk
	    not-s-good-statep-bad-car-expr
	    not-psw-run-lr-eval
	    once-errorp-always-errorp-step
	    program-body-assoc-comp-programs
	    s-eval-err-flag-not-run-fact
	    s-eval-l-eval-flag-run-flag-t)))

(disable lr-programs-properp-definedp-subrp-runtime-support)

(prove-lemma NOT-LESSP-HELP-FACT (rewrite)
  (implies (and (not (lessp x y))
		(not (lessp x z)))
	   (equal (lessp x (max y z)) f)))

(prove-lemma P-PSW-RUN-LR-APPLY-SUBR-LR-CHECK-RESOURCESP (rewrite)
  (implies (and (not (zerop c))
		(listp (s-expr s))
		(not (equal (car (s-expr s)) 'if))
		(not (equal (car (s-expr s)) 'quote))
		(equal (s-err-flag (s-eval 'list
					   (s-set-pos s (dv (s-pos s) 1))
					   c))
		       'run)
		(subrp (car (s-expr s)))
		(equal (p-psw (lr-eval 'list
				       (lr-set-pos (s->lr1 s l table)
						   (dv (s-pos s) 1))
				       c))
		       'run)
		(proper-p-statep (lr->p (s->lr1 s l table)))
		(lr-proper-heapp (p-data-segment l))
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(lr-s-similar-statesp (s-params s)
				      (s-temps s)
				      (s->lr1 s l table)
				      table)
		(s-good-statep s c)
		(lr-check-resourcesp flag s l c)
		(not (lessp (p-word-size l) (s-max-subr-reqs)))
		(not (equal flag 'list)))
	   (equal (p-psw (lr-apply-subr (s->lr1 s l table)
					(lr-eval 'list
						 (lr-set-pos (s->lr1 s
								     l
								     table)
							     (dv (s-pos s)
								 1))
						 c)))
		  'run))
  ((enable lr-apply-subr lr-check-resourcesp s-eval-ctrl-r s-eval-heap-r
	   s-eval-temp-r s-eval-ws-r)
   (expand (s-eval-r flag s c))
   (disable-theory addition)
   (disable lr-compile-programs lr-compile-body lr-count-free-nodes
	    lr-make-temp-name-alist lr-eval max s-eval s-eval-r
	    good-posp-list-nx-t-simple
	    good-posp1-list-good-posp-list-t
	    good-posp1-cons-lessp-4-if-lr-proper-exprp
	    length-p-temp-stk-lr-eval-flag-list
	    s-eval-err-flag-not-run-fact
	    s-eval-l-eval-flag-t
	    s-eval-l-eval-flag-run-flag-t)))

(prove-lemma STRIP-LOGIC-FNAMES-LR-COMPILE-PROGRAMS (rewrite)
  (equal (strip-logic-fnames (lr-compile-programs programs const-table))
	 (strip-logic-fnames programs)))

(prove-lemma STRIP-LOGIC-FNAMES-CDR-LR-COMPILE-PROGRAMS (rewrite)
  (equal (strip-logic-fnames (cdr (lr-compile-programs programs
						       const-table)))
	 (strip-logic-fnames (cdr programs))))

(prove-lemma LR-PROGRAMS-PROPERP-S->LR1-DEFINEDP-CDR-S-PROGS ()
  (implies (and (lr-programs-properp (s->lr1 s l table) table)
		(listp (s-expr s))
		(not (equal (car (s-expr s)) 'if))
		(not (equal (car (s-expr s)) 'quote))
		(not (subrp (car (s-expr s))))
		(litatom (car (s-expr s)))
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(s-programs-okp (cdr (s-progs s))))
	   (definedp (user-fname (car (s-expr s))) (cdr (s-progs s))))
  ((expand (lr-proper-exprp t
			    (lr-expr (s->lr1 s l table))
			    (strip-logic-fnames (cdr (s-progs s)))
			    (s-formals (s-prog s))
			    (strip-cars (temp-var-dcls (p-current-program
							(s->lr1 s
								l
								table))))
			    table))
   (use (lr-programs-properp-lr-proper-exprp-lr-expr
	 (l (s->lr1 s l table)) (table table)))
   (disable lr-compile-body lr-compile-programs lr-make-temp-name-alist
	    lr-proper-exprp
	    good-posp1-nlistp
	    good-posp1-list-good-posp-list-t
	    lr-programs-properp-funcall-not-caar-prog-seg
	    temp-var-dcls-assoc-p-current-program-s->lr1)))

(prove-lemma S-PROGRAMS-OKP-FORMALS-NOT-F ()
  (implies (and (s-programs-okp progs)
		(member prog progs))
	   (not (equal (s-formals prog) f))))

(prove-lemma NOT-LESSP-PLUS-ARITY-LENGTH-FORMALS (rewrite)
  (implies (and (listp (s-expr s))
		(not (equal (car (s-expr s)) 'if))
		(not (equal (car (s-expr s)) 'quote))
		(not (subrp (car (s-expr s))))
		(litatom (car (s-expr s)))
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(s-good-statep s c))
	   (equal (lessp (plus (arity (car (s-expr s))) x)
			 (length (formals (car (s-expr s)))))
		  f))
  ((enable arity-formals-not-quote
	   member-strip-cars-definedp)
   (expand (s-proper-exprp t
			   (s-expr s)
			   (strip-logic-fnames (cdr (s-progs s)))
			   (s-formals (s-prog s))
			   (s-temp-list (s-prog s))))
   (use (s-programs-okp-formals-body
	 (progs (cdr (s-progs s)))
	 (prog (assoc (user-fname (car (s-expr s))) (cdr (s-progs s)))))
	(s-programs-okp-formals-not-f
	 (progs (cdr (s-progs s)))
	 (prog (assoc (user-fname (car (s-expr s))) (cdr (s-progs s)))))
	(s-good-statep-s-proper-exprp-cur-expr (s s ) (c c)))
   (disable s-programs-okp)))

(prove-lemma LENGTH-LR-MAKE-TEMP-VAR-DCLS (rewrite)
  (equal (length (lr-make-temp-var-dcls temp-alist)) (length temp-alist)))

(prove-lemma LENGTH-LR-MAKE-TEMP-NAME-ALIST-1 (rewrite)
  (equal (length (lr-make-temp-name-alist-1 initial
					    num-list
					    temp-list
					    formals))
	 (length temp-list)))

(prove-lemma LENGTH-LR-MAKE-TEMP-NAME-ALIST (rewrite)
  (equal (length (lr-make-temp-name-alist temp-list formals))
	 (length temp-list)))

(prove-lemma P-CTRL-STK-SIZE-0 (rewrite)
  (equal (equal (p-ctrl-stk-size ctrl-stk) 0) (not (listp ctrl-stk))))

(prove-lemma LENGTH-MAKE-TEMPS-ENTRIES (rewrite)
  (equal (length (make-temps-entries list)) (length list)))

(prove-lemma S-EVAL-CTRL-R-FUNCALL-OPENER (rewrite)
  (let ((arg-s (s-eval 'list (s-set-pos s (dv (s-pos s) 1)) c)))
    (implies (and (not (zerop c))
		  (s-good-statep s c)
		  (listp (s-expr s))
		  (not (equal (car (s-expr s)) 'if))
		  (not (equal (car (s-expr s)) 'quote))
		  (not (subrp (car (s-expr s))))
		  (litatom (car (s-expr s)))
		  (not (equal flag 'list))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (equal (s-err-flag arg-s) 'run))
	     (equal
	      (s-eval-ctrl-r flag s c)
	      (max (s-eval-ctrl-r 'list
				  (s-set-pos s (dv (s-pos s) 1))
				  c)
		   (add1
		    (add1
		     (plus
		      (length (formals (car (s-expr s))))
		      (length (s-temp-list (assoc (user-fname
						   (car (s-expr s)))
						  (s-progs s))))
		      (s-eval-ctrl-r t
				     (s-fun-call-state arg-s
						       (car (s-expr s)))
				     (sub1 c)))))))))
  ((enable max-r s-eval-ctrl-r)
   (disable s-eval s-eval-r
	    s-eval-err-flag-not-run-fact
	    s-eval-l-eval-flag-run-flag-t)
   (expand (s-eval-r flag s c))))

(prove-lemma S-GOOD-STATEP-FORMALS-ASSOC-CDR-S-PROGS (rewrite)
  (implies (and (s-good-statep s c)
		(listp (s-expr s))
		(not (equal (car (s-expr s)) 'if))
		(not (equal (car (s-expr s)) 'quote))
		(not (subrp (car (s-expr s))))
		(good-posp1 (s-pos s)
			    (s-body (s-prog s)))
		(litatom (car (s-expr s)))
		(equal progs (cdr (s-progs s))))
	   (equal (s-formals (assoc (user-fname (car (s-expr s))) progs))
		  (formals (car (s-expr s)))))
  ((enable s-good-statep-not-car-s-expr-caar-s-progs)
   (use (s-good-statep-formals (s s) (c c)))
   (disable s-good-statep-formals)))

(prove-lemma NOT-LESSP-P-CTRL-STK-SIZE-MAKE-P-CALL-FRAME (rewrite)
  (let ((s-prog (assoc (user-fname (car (s-expr s))) (cdr (s-progs s))))
	(lr-eval (lr-eval 'list
			  (lr-set-pos (s->lr1 s l table) (dv (s-pos s) 1))
			  c)))
    (implies (and (listp (s-expr s))
		  (not (equal (car (s-expr s)) 'if))
		  (not (equal (car (s-expr s)) 'quote))
		  (not (subrp (car (s-expr s))))
		  (litatom (car (s-expr s)))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (s-good-statep s c)
		  (not (zerop c))
		  (proper-p-statep (lr->p (s->lr1 s l table)))
		  (lr-programs-properp (s->lr1 s l table) table)
		  (equal (length temp-list) (length (s-temp-list s-prog)))
		  (equal (p-psw lr-eval) 'run)
		  (equal (s-err-flag (s-eval 'list
					     (s-set-pos s (dv (s-pos s) 1))
					     c))
			 'run)
		  (not (lessp (p-max-ctrl-stk-size l)
			      (plus (p-ctrl-stk-size (p-ctrl-stk l))
				    (s-eval-ctrl-r flag s c))))
		  (not (equal flag 'list)))
	     (not (lessp (p-max-ctrl-stk-size l)
			 (p-ctrl-stk-size
			  (cons (make-p-call-frame
				 (formals (car (s-expr s)))
				 temp-stk
				 temp-list
				 pc)
				(p-ctrl-stk lr-eval)))))))
  ((enable s-good-statep-not-car-s-expr-caar-s-progs)
   (disable definedp first-n length lr-compile-body lr-compile-programs
	    lr-make-temp-name-alist make-p-call-frame pairlist reverse
	    equal-length-0 equal-sub1-0
	    good-posp1-nlistp
	    good-posp-list-nx-t-simple
	    length-nlistp
	    lr-eval-zerop-clock
	    not-psw-run-lr-eval
	    plus-zero-arg2
	    s-eval-err-flag-not-run-fact
	    s-eval-l-eval-flag-run-flag-t
	    s-eval-l-eval-flag-t)))

(prove-lemma DEFINEDP-0 (rewrite)
  (equal (definedp x 0) f))

(prove-lemma NOT-DEFINEDP-USER-FNAME-P-RUNTIME-SUPPORT-PROGRAMS (rewrite)
  (not (definedp (user-fname name) (p-runtime-support-programs)))
  ((enable user-fname)))

(prove-lemma COMP-PROGRAMS-ASSOC-CONS-OPENER (rewrite)
  (implies (not (equal (user-fname name) prog1-name))
	   (equal (assoc (user-fname name)
			 (comp-programs (cons (cons prog1-name prog1)
					      progs)))
		  (assoc (user-fname name) (comp-programs-1 progs))))
  ((enable name comp-programs
	   assoc-append-1
	   definedp-assoc-fact-1)
   (disable *1*p-runtime-support-programs)))

(prove-lemma LR-CHECK-RESOURCESP-LR-FUNCALL-P-PSW-RUN (rewrite)
  (implies (and (not (zerop c))
		(listp (s-expr s))
		(not (equal (car (s-expr s)) 'if))
		(not (equal (car (s-expr s)) 'quote))
		(not (subrp (car (s-expr s))))
		(litatom (car (s-expr s)))
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(equal (p-psw (lr-eval 'list
				       (lr-set-pos (s->lr1 s l table) pos)
				       c))
		       'run)
		(equal (s-err-flag (s-eval 'list (s-set-pos s pos) c)) 'run)
		(equal pos (dv (s-pos s) 1))
		(proper-p-statep (lr->p (s->lr1 s l table)))
		(s-good-statep s c)
		(lr-proper-heapp (p-data-segment l))
		(lr-check-resourcesp flag s l c)
		(not (equal flag 'list)))
	   (equal (p-psw (lr-funcall (s->lr1 s l table)
				     (lr-eval 'list
					      (lr-set-pos (s->lr1 s l table)
							  pos)
					      c)))
		  'run))
  ((enable lr-funcall lr-check-resourcesp
	   arity-formals-not-quote)
   (use (formal-vars-assoc-comp-programs-lr-programs-properp
	 (name (user-fname (car (s-expr s))))
	 (l (s->lr1 s l table))
	 (table table))
	(lr-programs-properp-s->lr1-definedp-cdr-s-progs
	 (s s) (l l) (table table)))
   (expand (lr-compile-programs (s-progs s) table))
   (disable definedp length lr-compile-body lr-compile-programs
	    lr-count-free-nodes lr-free-list-nodes lr-eval
	    lr-make-temp-name-alist make-p-call-frame p-ctrl-stk-size s-eval
	    formal-vars-assoc-comp-programs-lr-programs-properp
	    good-posp1-nlistp
	    good-posp-list-nx-t-simple
	    good-posp1-list-good-posp-list-t
	    p-ins-okp-backchainer
	    s-eval-ctrl-r-funcall-opener
	    s-eval-l-eval-flag-run-flag-t
	    s-eval-err-flag-not-run-fact)
   (disable-theory addition)))

(prove-lemma LESSP-MAX-ARG2 (rewrite)
  (not (lessp (max x y) y)))

(prove-lemma NOT-LESSP-PLUS-ARITY-LENGTH-FORMALS-ALT (rewrite)
  (implies (and (listp (s-expr s))
		(not (equal (car (s-expr s)) 'if))
		(not (equal (car (s-expr s)) 'quote))
		(not (subrp (car (s-expr s))))
		(litatom (car (s-expr s)))
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(s-good-statep s c))
	   (equal (lessp (plus x (arity (car (s-expr s))))
			 (length (formals (car (s-expr s)))))
		  f))
  ((use (not-lessp-plus-arity-length-formals (s s) (c c) (x x)))))

(prove-lemma LISTP-LR-COMPILE-PROGRAMS (rewrite)
  (equal (listp (lr-compile-programs progs table)) (listp progs))
  ((disable lr-compile-body)))

(prove-lemma CAAR-LR-COMPILE-PROGRAMS (rewrite)
  (implies (listp progs)
	   (equal (caar (lr-compile-programs progs table)) (caar progs)))
  ((disable lr-compile-body)))

(prove-lemma LENGTH-P-TEMP-STK-LR-EVAL-LR-FUNCALL (rewrite)
  (let ((lr-eval (lr-eval 'list (lr-set-pos (s->lr1 s l table) pos) c)))
    (implies (and (listp (s-expr s))
		  (not (subrp (car (s-expr s))))
		  (not (equal (car (s-expr s)) 'quote))
		  (not (equal (car (s-expr s)) 'if))
		  (litatom (car (s-expr s)))
		  (proper-p-statep (lr->p (s->lr1 s l table)))
		  (good-posp1 (s-pos s) (s-body (s-prog s)))
		  (s-good-statep s c)
		  (lr-programs-properp (s->lr1 s l table) table)
		  (equal (p-psw lr-eval) 'run)
		  (equal (p-psw (lr-funcall (s->lr1 s l table) lr-eval))
			 'run)
		  (equal (s-err-flag (s-eval 'list (s-set-pos s pos) c))
			 'run)
		  (equal pos (dv (s-pos s) 1)))
	     (equal (length (p-temp-stk (lr-funcall (s->lr1 s l table)
						    lr-eval)))
		    (length (p-temp-stk l)))))
  ((enable lr-funcall
	   arity-formals-not-quote
	   member-strip-cars-definedp)
   (expand (s-proper-exprp t
			   (s-expr s)
			   (strip-logic-fnames (cdr (s-progs s)))
			   (s-formals (s-prog s))
			   (s-temp-list (s-prog s))))
   (use (s-programs-okp-formals-body
	 (progs (cdr (s-progs s)))
	 (prog (assoc (user-fname (car (s-expr s))) (cdr (s-progs s)))))
	(s-programs-okp-formals-not-f
	 (progs (cdr (s-progs s)))
	 (prog (assoc (user-fname (car (s-expr s))) (cdr (s-progs s)))))
	(s-good-statep-s-proper-exprp-cur-expr (s s ) (c c)))
   (disable lr-compile-body lr-compile-programs lr-eval
	    lr-make-temp-name-alist p-call-okp s-eval s-programs-okp
	    lr-eval-leaves-listp-p-temp-stk
	    lr-eval-zerop-clock
	    good-posp1-cons-lessp-4-if-lr-proper-exprp
	    good-posp1-list-good-posp-list-t
	    length-p-temp-stk-lr-funcall
	    not-lessp-p-max-temp-stk-size-lr-funcall
	    not-psw-run-lr-eval
	    s-eval-l-eval-flag-run-flag-t)))

(prove-lemma P-CTRL-STK-SIZE-P-CTRL-STK-LR-FUNCALL (rewrite)
  (implies (equal (p-psw (lr-funcall l new-l)) 'run)
	   (equal (p-ctrl-stk-size (p-ctrl-stk (lr-funcall l new-l)))
		  (plus 2
			(length (formal-vars (assoc (user-fname
						     (car (lr-expr l)))
						    (p-prog-segment l))))
			(length (temp-var-dcls (assoc (user-fname
						       (car (lr-expr l)))
						      (p-prog-segment l))))
			(p-ctrl-stk-size (p-ctrl-stk new-l)))))
  ((enable lr-funcall)
   (disable make-p-call-frame p-call-okp)))

(prove-lemma LR-PROGRAMS-PROPERP-S->LR1-DEFINEDP-S-PROGS ()
  (implies (and (lr-programs-properp (s->lr1 s l table) table)
		(listp (s-expr s))
		(not (equal (car (s-expr s)) 'if))
		(not (equal (car (s-expr s)) 'quote))
		(not (subrp (car (s-expr s))))
		(litatom (car (s-expr s)))
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(s-programs-okp (cdr (s-progs s))))
	   (definedp (user-fname (car (s-expr s))) (s-progs s)))
  ((use (lr-programs-properp-s->lr1-definedp-cdr-s-progs
	 (s s) (l l) (table table)))
   (expand (definedp (car (s-expr s)) (s-progs s)))
   (disable lr-compile-programs
	    lr-programs-properp-funcall-not-caar-prog-seg
	    lr-programs-properp-lr->p-s->lr1-definedp-s-pname)))

(prove-lemma S-EVAL-CTRL-HEAP-TEMP-WS-S-FUN-CALL-STATE-OPENER (rewrite)
  (let ((s-eval (s-eval 'list (s-set-pos s (dv (s-pos s) 1)) c)))
    (implies (and (not (zerop c))
		  (listp (s-expr s))
		  (not (equal (car (s-expr s)) 'if))
		  (not (equal (car (s-expr s)) 'quote))
		  (not (subrp (car (s-expr s))))
		  (litatom (car (s-expr s)))
		  (s-good-statep s c)
		  (equal (s-err-flag s-eval) 'run)
		  (not (equal flag 'list)))
	     (and
	      (equal
	       (s-eval-ctrl-r flag s c)
	       (max (s-eval-ctrl-r 'list
				   (s-set-pos s (dv (s-pos s) 1))
				   c)
		    (plus 2
			  (length (s-formals (assoc (user-fname
						     (car (s-expr s)))
						    (s-progs s))))
			  (length (s-temp-list (assoc (user-fname
						       (car (s-expr s)))
						      (s-progs s))))
			  (s-eval-ctrl-r t
					 (s-fun-call-state
					  s-eval
					  (car (s-expr s)))
					 (sub1 c)))))
	      (equal
	       (s-eval-heap-r flag s c)
	       (plus (s-eval-heap-r 'list
				    (s-set-pos s (dv (s-pos s) 1))
				    c)
		     (s-eval-heap-r t
				    (s-fun-call-state s-eval
						      (car (s-expr s)))
				    (sub1 c))))
	      (equal
	       (s-eval-temp-r flag s c)
	       (max (s-eval-temp-r 'list
				   (s-set-pos s (dv (s-pos s) 1))
				   c)
		    (s-eval-temp-r t
				   (s-fun-call-state s-eval
						     (car (s-expr s)))
				   (sub1 c))))
	      (equal
	       (s-eval-ws-r flag s c)
	       (max (s-eval-ws-r 'list
				 (s-set-pos s (dv (s-pos s) 1))
				 c)
		    (s-eval-ws-r t
				 (s-fun-call-state s-eval
						   (car (s-expr s)))
				 (sub1 c)))))))
  ((enable max-r s-eval-ctrl-r s-eval-heap-r s-eval-temp-r s-eval-ws-r)
   (disable-theory addition)
   (disable max plus s-eval s-eval-r
	    good-posp1-nlistp
	    good-posp-dv-1-funcall
	    s-eval-err-flag-not-run-fact
	    s-eval-l-eval-flag-run-flag-t
	    s-good-statep-formals
	    s-good-statep-formals-assoc-cdr-s-progs)
   (expand (s-eval-r flag s c))))

(prove-lemma LR-CHECK-RESOURCESP-LR-FUNCALL-S-FUN-CALL-STATE (rewrite)
  (implies (and (not (zerop c))
		(listp (s-expr s))
		(not (equal (car (s-expr s)) 'if))
		(not (equal (car (s-expr s)) (s-temp-eval)))
		(not (equal (car (s-expr s)) (s-temp-test)))
		(not (equal (car (s-expr s)) (s-temp-fetch)))
		(not (equal (car (s-expr s)) 'quote))
		(not (subrp (car (s-expr s))))
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(litatom (car (s-expr s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(equal (p-psw (lr-eval 'list
				       (lr-set-pos (s->lr1 s l table) pos)
				       c))
		       'run)
		(equal (s-err-flag (s-eval 'list (s-set-pos s pos) c)) 'run)
		(equal pos (dv (s-pos s) 1))
		(proper-p-statep (lr->p (s->lr1 s l table)))
		(s-good-statep s c)
		(lr-proper-heapp (p-data-segment l))
		(lr-check-resourcesp flag s l c)
		(not (equal flag 'list))
		(lr-s-similar-statesp (s-params s)
				      (s-temps s)
				      (s->lr1 s l table)
				      table))
	   (lr-check-resourcesp t
				(s-fun-call-state (s-eval 'list
							  (s-set-pos s pos)
							  c)
						  (car (s-expr s)))
				(lr-funcall
				 (s->lr1 s l table)
				 (lr-eval 'list
					  (lr-set-pos (s->lr1 s l table)
						      pos)
					  c))
				(sub1 c)))
  ((enable lr-check-resourcesp
	   commutativity-of-plus)
   (use (lr-check-resourcesp-lr-funcall-p-psw-run
	 (s s) (l l) (table table) (c c) (flag flag) (pos pos))
	(lr-programs-properp-s->lr1-definedp-s-progs
	 (s s) (l l) (table table)))
   (disable-theory addition)
   (disable lr-compile-body lr-count-free-nodes lr-eval lr-free-list-nodes
	    length lr-make-temp-name-alist make-temps-entries max
	    p-ctrl-stk-size s-eval s-eval-r
	    good-posp-list-nx-t-simple
	    good-posp1-list-good-posp-list-t
	    good-posp1-cons-lessp-4-if-lr-proper-exprp
	    length-nlistp length-p-temp-stk-lr-funcall
	    lr-check-resourcesp-lr-funcall-p-psw-run
	    lr-programs-properp-funcall-not-caar-prog-seg
	    not-adpp-untag-add-addr-adpp-untag
	    s-eval-err-flag-not-run-fact
	    s-eval-l-eval-flag-t
	    s-eval-l-eval-flag-run-flag-t)))

(disable s-eval-ctrl-heap-temp-ws-s-fun-call-state-opener)

(prove-lemma S-EVAL-FLAG-RUN-CAR-S-APPLY-SUBR-R-NOT-ZERO (rewrite)
  (implies (and (listp (s-expr s))
		(not (equal (car (s-expr s)) 'if))
		(not (equal (car (s-expr s)) 'quote))
		(equal (s-err-flag (s-eval 'list
					   (s-set-pos s (dv (s-pos s) 1))
					   c))
		       'run)
		(subrp (car (s-expr s)))
		(equal (p-psw (lr-apply-subr (s->lr1 s l table) new-l))
		       'run)
		(good-posp1 (s-pos s) (s-body (s-prog s)))
		(s-good-statep s c))
	   (not (lessp (car (s-apply-subr-r (car (s-expr s))
					    (s-eval 'list
						    (s-set-pos s
							       (dv (s-pos s)
								   1))
						    c)))
		       1)))
  ((enable lr-apply-subr p-run-subr s-apply-subr-r)
   (disable s-eval s-eval-r)))

(prove-lemma LENGTH-P-TEMP-STK-LR-EVAL-LR-SET-POS-FLAG-T (rewrite)
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(good-posp1 pos (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(s-good-statep s c)
		(equal (p-psw (lr-eval t
				       (lr-set-pos (s->lr1 s l table) pos)
				       c))
		       'run))
	   (equal (length (p-temp-stk (lr-eval t
					       (lr-set-pos (s->lr1 s
								   l
								   table)
							   pos)
					       c)))
		  (plus 1 (length (p-temp-stk l)))))
  ((use (length-p-temp-stk-lr-eval
	 (flag t) (l (lr-set-pos (s->lr1 s l table) pos))
	 (table table) (c c)))
   (expand (lr-compile-programs (s-progs s) table))
   (disable lr-compile-body lr-compile-programs lr-eval
	    lr-make-temp-name-alist)))

(prove-lemma S-EVAL-FLAG-RUN-S-EVAL-TEMP-R-NOT-ZERO ()
  (implies (and (equal (p-psw (lr-eval flag (s->lr1 s l table) c)) 'run)
		(equal (s-err-flag (s-eval flag s c)) 'run)
		(good-posp flag (s-pos s) (s-body (s-prog s)))
		(s-good-statep s c)
		(not (equal flag 'list)))
	   (not (lessp (s-eval-temp-r flag s c) 1)))
  ((enable s-eval-temp-r
	   p-psw-run-lr-if-ok-p-psw-run
	   lr-eval-if-p-psw-1)
   (induct (ihint-2 flag s l table c))
   (expand (s-eval flag s c)
	   (s-eval-r flag s c) (s-eval-r 'list s c) (s-eval-r flag s 0))
   (disable lr-eval s-eval s-eval-r)))

(prove-lemma P-PSW-RUN-P-PSW-LR-IF-OK-NOT-RUN-CHECK-RESOURCESP (rewrite)
  (implies (and (not (equal flag 'list))
		(not (zerop c))
		(listp (s-expr s))
		(equal (car (s-expr s)) 'if)
		(s-good-statep s c)
		(lr-programs-properp (s->lr1 s l table) table)
		(proper-p-statep (lr->p (s->lr1 s l table)))
		(equal (s-err-flag (s-eval t
					   (s-set-pos s (dv (s-pos s) 1))
					   c))
		       'run)
		(not (equal (p-psw (lr-if-ok
				    (lr-eval t
					     (lr-set-pos (s->lr1 s l table)
							 (dv (s-pos s) 1))
					     c)))
			    'run))
		(equal (p-psw (lr-eval t
				       (lr-set-pos (s->lr1 s l table)
						   (dv (s-pos s) 1))
				       c))
		       'run)
		(good-posp1 (s-pos s) (s-body (s-prog s))))
	   (not (lr-check-resourcesp flag s l c)))
  ((enable lr-check-resourcesp lr-if-ok s-eval-temp-r)
   (expand (s-eval-r flag s c))
   (use (s-eval-flag-run-s-eval-temp-r-not-zero
	 (flag t) (s (s-set-pos s (dv (s-pos s) 1)))
	 (table table) (l l) (c c)))
   (disable lr-compile-body lr-count-free-nodes lr-eval lr-free-list-nodes
	    length lr-make-temp-name-alist make-temps-entries max
	    p-ctrl-stk-size s-eval s-eval-r
	    good-posp-list-nx-t-simple
	    good-posp1-list-good-posp-list-t
	    good-posp1-cons-lessp-4-if-lr-proper-exprp
	    length-nlistp length-p-temp-stk-lr-funcall
	    lr-check-resourcesp-lr-funcall-p-psw-run
	    lr-programs-properp-funcall-not-caar-prog-seg
	    not-adpp-untag-add-addr-adpp-untag
	    s-eval-err-flag-not-run-fact
	    s-eval-l-eval-flag-t
	    s-eval-l-eval-flag-run-flag-t)))

(prove-lemma NOT-LR-CHECK-RESOURCESP-TEMP-TEST-BAD-MAX-TEMP-STK-SIZE
    (rewrite)
  (implies (and (not (equal flag 'list))
		(not (equal c 0))
		(numberp c)
		(listp (s-expr s))
		(equal (car (s-expr s)) (s-temp-test))
		(lessp (p-max-temp-stk-size l)
		       (plus 2 (length (p-temp-stk l))))
		(s-good-statep s c))
	   (not (lr-check-resourcesp flag s l c)))
  ((enable lr-check-resourcesp lr-if-ok s-eval-temp-r)
   (expand (s-eval-r flag s c))
   (disable lr-compile-body lr-count-free-nodes lr-eval lr-free-list-nodes
	    length lr-make-temp-name-alist make-temps-entries max
	     s-eval s-eval-r
	    lr-check-resourcesp-lr-funcall-p-psw-run
	    s-eval-err-flag-not-run-fact
	    s-eval-l-eval-flag-t
	    s-eval-l-eval-flag-run-flag-t)))

(prove-lemma LR-EVAL-S-EVAL-FLAG-RUN (rewrite)
  (implies (and (proper-p-statep (lr->p (s->lr1 s l table)))
		(lr-proper-heapp (p-data-segment l))
		(good-posp flag (s-pos s) (s-body (s-prog s)))
		(lr-programs-properp (s->lr1 s l table) table)
		(lr-s-similar-statesp (s-params s)
				      (s-temps s)
				      (s->lr1 s l table)
				      table)
		(s-good-statep s c)
		(s-all-temps-setp flag
				  (if (equal flag 'list)
				      (s-expr-list s)
				      (s-expr s))
				  (temp-alist-to-set (s-temps s)))
		(s-all-progs-temps-setp (s-progs s))
		(s-check-temps-setp (s-temps s))
		(equal (s-err-flag (s-eval flag s c)) 'run)
		(lr-check-resourcesp flag s l c)
		(not (lessp (p-word-size l) (s-max-subr-reqs))))
	   (equal (p-psw (lr-eval flag (s->lr1 s l table) c)) 'run))
  ((induct (ihint-2 flag s l table c))
   (disable-theory addition)
   (enable p-psw-run-lr-if-ok-p-psw-run)
   (expand (s-eval flag s c) (s-eval 'list s c) (s-eval flag s 0)
	   (s-all-temps-setp flag
			     (s-expr s)
			     (temp-alist-to-set (s-temps s)))
	   (s-all-temps-setp 'list
			     (s-expr-list s)
			     (temp-alist-to-set (s-temps s))))
   (disable lr-compile-body lr-eval lr-compile-programs
	    lr-make-temp-name-alist max s-collect-all-temps s-all-temps-setp
	    s-eval
	    good-posp-list-nx-t-simple
	    l-proper-expr-s-all-temps-setp
	    lr-programs-properp-lr->p-s->lr1-definedp-s-pname
	    proper-p-statep-lr->p-strip-cars-bindings-ctrl-stk
	    s-eval-l-eval-flag-t
	    s-eval-l-eval-flag-run-flag-t)))

(prove-lemma PLISTP-LR-COMPILE-BODY-1 (rewrite)
  (implies (plistp prog)
	   (plistp (lr-compile-body flag prog temp-alist table))))

(defn L-RESTRICT-SUBRPS (flag expr)
  (cond ((equal flag 'list)
	 (if (listp expr)
	     (and (l-restrict-subrps t (car expr))
		  (l-restrict-subrps 'list (cdr expr)))
	     t))
	((listp expr)
	 (cond ((equal (car expr) 'quote) t)
	       ((equal (car expr) 'if)
		(l-restrict-subrps 'list (cdr expr)))
	       ((subrp (car expr))
		(and (definedp (car expr) (p-runtime-support-programs))
		     (l-restrict-subrps 'list (cdr expr))))
	       ((body (car expr))
		(l-restrict-subrps 'list (cdr expr)))
	       (t t)))
	(t t)))

(defn L-RESTRICT-SUBRPS-PROGS (pnames)
  (if (listp pnames)
      (and (l-restrict-subrps t (body (car pnames)))
	   (l-restrict-subrps-progs (cdr pnames)))
      t))
 
(defn S-RESTRICT-SUBRPS (flag expr)
  (cond ((equal flag 'list)
	 (if (listp expr)
	     (and (s-restrict-subrps t (car expr))
		  (s-restrict-subrps 'list (cdr expr)))
	     t))
	((listp expr)
	 (cond ((equal (car expr) 'quote) t)
	       ((or (equal (car expr) (s-temp-fetch))
		    (equal (car expr) (s-temp-eval))
		    (equal (car expr) (s-temp-test)))
		(s-restrict-subrps t (cadr expr)))
	       ((equal (car expr) 'if)
		(s-restrict-subrps 'list (cdr expr)))
	       ((subrp (car expr))
		(and (definedp (car expr) (p-runtime-support-programs))
		     (s-restrict-subrps 'list (cdr expr))))
	       ((body (car expr))
		(s-restrict-subrps 'list (cdr expr)))
	       (t t)))
	(t t)))

(defn S-RESTRICT-SUBRPS-PROGS (progs)
  (if (listp progs)
      (and (s-restrict-subrps t (s-body (car progs)))
	   (s-restrict-subrps-progs (cdr progs)))
      t))

(prove-lemma S-PROPER-EXPRP-PLIST-TEMP-LIST (rewrite)
  (equal (s-proper-exprp flag expr program-names formals (plist temp-list))
	 (s-proper-exprp flag expr program-names formals temp-list))
  ((disable append-plist-lastcdr)))

(prove-lemma NOT-LISTP-S-PROGS-NOT-S-GOOD-STATEP (rewrite)
  (implies (not (listp (s-progs s)))
	   (not (s-good-statep s c)))
  ((enable s-good-statep)))

(prove-lemma LENGTH-LR-INIT-HEAP-CONTENTS (rewrite)
  (equal (length (lr-init-heap-contents addr size))
	 (add1 (times size (lr-node-size)))))

(prove-lemma FETCH-CONS (rewrite)
  (equal (fetch (list x (cons name1 n))
		(cons (cons name2 contents)
		      rest-data-seg))
	 (if (equal name1 name2)
	     (get n contents)
	     (fetch (list x (cons name1 n)) rest-data-seg)))
  ((enable fetch untag)))

(prove-lemma LR-S-SIMILAR-CONST-TABLE-CONS (rewrite)
  (equal (lr-s-similar-const-table (cons (cons object addr) table) data-seg)
	 (and (lr-valp object addr data-seg)
	      (lr-s-similar-const-table table data-seg))))

(prove-lemma LR-S-SIMILAR-CONST-TABLE-NIL (rewrite)
  (lr-s-similar-const-table nil data-seg))

(prove-lemma LR-INIT-HEAP-CONTENTS-ADD1-OPENER (rewrite)
  (equal (lr-init-heap-contents addr (add1 size))
	 (append (lr-new-node (tag 'nat (lr-init-tag))
			      (add-addr addr (lr-node-size))
			      (tag 'nat 0)
			      (tag 'nat 0))
		 (lr-init-heap-contents (add-addr addr (lr-node-size))
					size))))

(prove-lemma DEPOSIT-CONS (rewrite)
  (equal (deposit object
		  (list x (cons name1 n))
		  (cons (cons name2 contents) rest-data-seg))
	 (if (equal name1 name2)
	     (cons (cons name1 (put object n contents)) rest-data-seg)
	     (cons (cons name2 contents)
		   (deposit object (list x (cons name1 n)) rest-data-seg))))
  ((enable deposit untag)))

(prove-lemma ADPP-CONS-PACK-OPENER (rewrite)
  (implies (numberp n)
	   (equal (adpp (cons (pack xxx) n)
			(cons (cons (pack yyy) contents)
			      rest))
		  (if (equal xxx yyy)
		      (lessp n (length contents))
		      (adpp (cons (pack xxx) n) rest))))
  ((enable adpp)))

(prove-lemma FETCH-DEPOSIT-A-LIST (rewrite)
  (implies (and (numberp (offset addr1))
		(numberp (offset addr2))
		(listp list))
	   (equal (fetch addr1
			 (deposit-a-list list addr2 data-seg))
		  (if (definedp (area-name addr2) data-seg)
		      (if (equal (area-name addr1) (area-name addr2))
			  (if (and (not (lessp (offset addr1)
					       (offset addr2)))
				   (lessp (offset addr1)
					  (plus (offset addr2)
						(length list))))
			      (get (difference (offset addr1)
					       (offset addr2))
				   list)
			      (fetch addr1 data-seg))
			  (fetch addr1 data-seg))
		      (fetch addr1 data-seg))))
  ((enable deposit-a-list
	   get-cons)))

(prove-lemma LR-VALP-0-LR-0-ADDR-OPENER (rewrite)
  (equal (lr-valp 0 (identity (lr-0-addr)) data-seg)
	 (and (adpp (identity (untag (lr-0-addr))) data-seg)
	      (equal (type (fetch (identity
				   (add-addr (lr-0-addr)
					     (lr-ref-count-offset)))
				  data-seg))
		     'nat)
	      (equal (untag (fetch (identity (lr-0-addr)) data-seg))
		     (lr-add1-tag))
	      (equal (untag (fetch (identity
				    (add-addr (lr-0-addr)
					      (lr-unbox-nat-offset)))
				   data-seg))
		     0))))

(disable lr-valp-0-lr-0-addr-opener)

(prove-lemma LR-VALP-T-LR-T-ADDR-OPENER (rewrite)
  (equal (lr-valp t (identity (lr-t-addr)) data-seg)
	 (and (adpp (identity (untag (lr-t-addr))) data-seg)
	      (equal (type (fetch (identity
				   (add-addr (lr-t-addr)
					     (lr-ref-count-offset)))
				  data-seg))
		     'nat)
	      (equal (untag (fetch (identity (lr-t-addr)) data-seg))
		     (lr-true-tag)))))

(disable lr-valp-t-lr-t-addr-opener)

(prove-lemma LR-VALP-F-LR-F-ADDR-OPENER (rewrite)
  (equal (lr-valp f (identity (lr-f-addr)) data-seg)
	 (and (adpp (identity (untag (lr-f-addr))) data-seg)
	      (equal (type (fetch (identity
				   (add-addr (lr-f-addr)
					     (lr-ref-count-offset)))
				  data-seg))
		     'nat)
	      (equal (untag (fetch (identity (lr-f-addr)) data-seg))
		     (lr-false-tag)))))

(disable lr-valp-f-lr-f-addr-opener)

(prove-lemma DEFINEDP-TABLE-DEFINEDP-CDR-LR-COMPILE-QUOTE (rewrite)
  (implies (definedp x table)
	   (definedp x
		     (cdr (lr-compile-quote flag object data-seg table)))))

(prove-lemma DEFINEDP-CAR-LR-COMPILE-QUOTE (rewrite)
  (equal (definedp x (car (lr-compile-quote flag object data-seg table)))
	 (definedp x data-seg)))

(prove-lemma LR-PROPER-P-AREASP-CAR-LR-COMPILE-QUOTE (rewrite)
  (implies (lr-proper-p-areasp data-seg)
	   (lr-proper-p-areasp (car (lr-compile-quote flag
						      object
						      data-seg
						      table)))))

(prove-lemma LENGTH-DEPOSIT-A-LIST (rewrite)
  (implies (listp list)
	   (equal (length (cdr (assoc name
				      (deposit-a-list list addr data-seg))))
		  (if (definedp (area-name addr) data-seg)
		      (if (equal (area-name addr) name)
			  (if (lessp (length (cdr (assoc name data-seg)))
				     (plus (offset addr) (length list)))
			      (plus (offset addr) (length list))
			      (length (cdr (assoc name data-seg))))
			  (length (cdr (assoc name data-seg))))
		      (length (cdr (assoc name data-seg))))))
  ((induct (deposit-a-list list addr data-seg))
   (enable deposit-a-list)))

(prove-lemma ADPP-LR-COMPILE-QUOTE (rewrite)
  (implies (adpp addr data-seg)
	   (adpp addr (car (lr-compile-quote flag object data-seg table))))
  ((induct (lr-compile-quote flag object data-seg table))
   (enable adpp-deposit-anything-at-all)
   (expand (lr-compile-quote flag object data-seg table)
	   (lr-compile-quote flag t data-seg table)
	   (lr-compile-quote 'list object data-seg table))
   (disable lr-compile-quote
	    deposit-a-list-cons-opener)))

(prove-lemma ADPP-UNTAG-DEFINEDP-AREA-NAME-FREE-PTR (rewrite)
  (implies (adpp (untag (lr-fp-addr)) data-seg)
	   (definedp (identity (area-name (lr-fp-addr))) data-seg))
  ((use (adpp-untag-definedp-area-name (addr (lr-fp-addr))
				       (data-seg data-seg)))))

(prove-lemma LR-MAX-NODE-DEPOSIT-A-LIST (rewrite)
  (implies (and (adpp (untag addr) data-seg)
		(listp list)
		(lessp (plus (offset addr) (length list))
		       (length (cdr (assoc (area-name addr) data-seg)))))
	   (equal (lr-max-node (deposit-a-list list addr data-seg))
		  (lr-max-node data-seg)))
  ((enable adpp area-name lr-max-node offset)
   (disable deposit-a-list)))

(defn ALL-P-OBJECTS-LOOKUP (list table p)
  (if (listp list)
      (and (p-objectp (cdr (assoc (car list) table)) p)
	   (all-p-objects-lookup (cdr list) table p))
      t))

(prove-lemma PROPER-P-ALISTP-ALL-LITATOMS-ALL-P-OBJECTPS-LOOKUP (rewrite)
  (implies (and (all-litatoms (strip-cars params))
		(all-p-objects-lookup (strip-cdrs params) table p))
	   (proper-p-alistp (pair-formals-with-addresses params table) p)))

(prove-lemma DEFINEDP-TABLE-DEFINEDP-CDR-LR-DATA-SEG-TABLE-BODY (rewrite)
  (implies (definedp object table)
	   (definedp object (cdr (lr-data-seg-table-body flag
							 expr
							 data-seg
							 table)))))

(prove-lemma DEFINEDP-TABLE-DEFINEDP-CDR-LR-DATA-SEG-TABLE-LIST (rewrite)
  (implies (definedp object table)
	   (definedp object (cdr (lr-data-seg-table-list progs
							 data-seg
							 table)))))

(prove-lemma DEFINEDP-TABLE-DEFINEDP-CDR-LR-INIT-DATA-SEG-TABLE (rewrite)
  (implies (definedp object table)
	   (definedp object (cdr (lr-init-data-seg-table params
							 data-seg
							 table))))
  ((disable lr-compile-quote)))

(prove-lemma DEFINEDP-TABLE-DEFINEDP-CAR-LR-DATA-SEG-TABLE-BODY (rewrite)
  (implies (definedp name data-seg)
	   (definedp name (car (lr-data-seg-table-body flag
						       expr
						       data-seg
						       table)))))

(prove-lemma DEFINEDP-TABLE-DEFINEDP-CAR-LR-DATA-SEG-TABLE-LIST (rewrite)
  (implies (definedp name data-seg)
	   (definedp name (car (lr-data-seg-table-list progs
						       data-seg
						       table)))))

(prove-lemma EQUAL-LENGTHS-SAME-SIGNATURE-CAR-LR-COMPILE-QUOTE (rewrite)
  (implies (same-signature data-seg
			   (car (lr-compile-quote flag
						  object
						  data-seg
						  table)))
	   (equal (length (cdr (assoc name
				      (car (lr-compile-quote flag
							     object
							     data-seg
							     table)))))
		  (length (cdr (assoc name data-seg)))))
  ((enable same-signature-implies-equal-lengths)
   (disable lr-compile-quote)))

(prove-lemma ADPP-SAME-SIGNATURE-CAR-LR-COMPILE-QUOTE (rewrite)
  (implies (same-signature data-seg
			   (car (lr-compile-quote flag
						  object
						  data-seg
						  table)))
	   (equal (adpp adp (car (lr-compile-quote flag
						   object
						   data-seg
						   table)))
		  (adpp adp data-seg)))
  ((use (adpp-same-signature (adp adp)
			     (data-seg1 (car (lr-compile-quote flag
							       object
							       data-seg
							       table)))
			     (data-seg2 data-seg)))
   (disable lr-compile-quote)))

(prove-lemma SAME-SIGNATURE-CAR-LR-COMPILE-QUOTE-HELPER (rewrite)
  (let ((pair (lr-compile-quote 'list
				(list (car object) (cdr object))
				data-seg
				table)))
    (implies (and (lr-proper-free-listp (car pair))
		  (same-signature data-seg (car pair))
		  (lr-proper-p-areasp data-seg)
		  (definedp (lr-heap-name) data-seg)
		  (lr-boundary-nodep (lr-max-node data-seg))
		  (not (lessp (sub1 (length (cdr (assoc (lr-heap-name)
							data-seg))))
			      (plus (offset (fetch (lr-fp-addr)
						   (car pair)))
				    (length list)))))
	     (same-signature data-seg
			     (deposit-a-list list
					     (fetch (identity (lr-fp-addr))
						    (car pair))
					     (car pair)))))
  ((enable definedp-listp-cdr-assoc-lr-proper-p-areasp
	   lr-max-node-same-signature
	   transitivity-of-same-signature)
   (use (lr-proper-free-listp-opener-2
	 (data-seg (car (lr-compile-quote 'list
					  (list (car object) (cdr object))
					  data-seg
					  table)))))
   (disable lr-compile-quote)))

(prove-lemma SAME-SIGNATURE-CAR-LR-COMPILE-QUOTE-GENERALIZED ()
  (implies (and (lr-proper-free-listp data-seg)
		(lr-proper-p-areasp data-seg)
		(definedp (lr-heap-name) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg)))
	   (and (same-signature data-seg
				(car (lr-compile-quote flag
						       object
						       data-seg
						       table)))
		(lr-proper-free-listp (car (lr-compile-quote flag
							     object
							     data-seg
							     table)))))
  ((induct (lr-compile-quote flag object data-seg table))
   (disable-theory addition)
   (enable adpp-deposit-anything-at-all
	   adpp-untag-lessp-offset
	   adpp-untag-numberp-offset
	   lr-max-node-same-signature
	   same-signature-deposit
	   transitivity-of-same-signature)
   (expand (lr-compile-quote flag object data-seg table)
	   (lr-compile-quote 'list object data-seg table)
	   (lr-compile-quote flag t data-seg table))
   (disable lr-compile-quote
	    deposit-a-list-cons-opener)))

(disable equal-lengths-same-signature-car-lr-compile-quote)
(disable adpp-same-signature-car-lr-compile-quote)

(prove-lemma LR-PROPER-FREE-LISTP-CAR-LR-COMPILE-QUOTE (rewrite)
  (implies (and (lr-proper-free-listp data-seg)
		(lr-proper-p-areasp data-seg)
		(definedp (lr-heap-name) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg)))
	   (lr-proper-free-listp (car (lr-compile-quote flag
							object
							data-seg
							table))))
  ((use (same-signature-car-lr-compile-quote-generalized
	 (flag flag) (object object) (data-seg data-seg) (table table)))
   (disable-theory addition)
   (disable lr-compile-quote)))

(prove-lemma P-OBJECTP-CAR-LR-COMPILE-QUOTE (rewrite)
  (implies (and (p-objectp object1
			   (p-state pc ctrl-stk temp-stk prog-seg
				    data-seg
				    max-ctrl
				    max-temp
				    word-size
				    psw))
		(lr-proper-free-listp data-seg)
		(lr-proper-p-areasp data-seg)
		(definedp (lr-heap-name) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg)))
	   (p-objectp object1
		      (p-state pc ctrl-stk temp-stk prog-seg
			       (car (lr-compile-quote flag
						      object2
						      data-seg
						      table))
			       max-ctrl
			       max-temp
			       word-size
			       psw)))
  ((disable lr-compile-quote)
   (use (same-signature-car-lr-compile-quote-generalized
	 (flag flag) (object object2) (data-seg data-seg) (table table)))))

(prove-lemma LR-PROPER-P-AREASP-CAR-LR-DATA-SEG-TABLE-BODY (rewrite)
  (implies (lr-proper-p-areasp data-seg)
	   (lr-proper-p-areasp (car (lr-data-seg-table-body flag
							    expr
							    data-seg
							    table))))
  ((induct (lr-data-seg-table-body flag expr data-seg table))
   (expand (lr-data-seg-table-body flag expr data-seg table)
	   (lr-data-seg-table-body 'list expr data-seg table))
   (disable-theory addition)
   (disable lr-compile-quote lr-data-seg-table-body)))

(prove-lemma SAME-SIGNATURE-CAR-LR-COMPILE-QUOTE (rewrite)
  (implies (and (lr-proper-free-listp data-seg)
		(lr-proper-p-areasp data-seg)
		(definedp (lr-heap-name) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg)))
	   (same-signature data-seg
			   (car (lr-compile-quote flag
						  object
						  data-seg
						  table))))
  ((use (same-signature-car-lr-compile-quote-generalized
	 (flag flag) (object object) (data-seg data-seg) (table table)))
   (disable-theory addition)
   (disable lr-compile-quote)))

(prove-lemma SAME-SIGNATURE-CAR-LR-DATA-SEG-TABLE-BODY (rewrite)
  (implies (and (lr-proper-free-listp data-seg)
		(lr-proper-p-areasp data-seg)
		(definedp (lr-heap-name) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg)))
	   (and
	    (same-signature data-seg
			    (car (lr-data-seg-table-body flag
							 expr
							 data-seg
							 table)))
	    (lr-proper-free-listp (car (lr-data-seg-table-body flag
							       expr
							       data-seg
							       table)))))
  ((induct (lr-data-seg-table-body flag expr data-seg table))
   (enable lr-max-node-same-signature
	   transitivity-of-same-signature)
   (expand (lr-data-seg-table-body flag expr data-seg table)
	   (lr-data-seg-table-body 'list expr data-seg table))
   (disable-theory addition)
   (disable lr-compile-quote lr-data-seg-table-body)))

(disable same-signature-car-lr-compile-quote)

(prove-lemma LR-MAX-NODE-CAR-LR-DATA-SEG-TABLE-BODY (rewrite)
  (implies (and (lr-proper-free-listp data-seg)
		(lr-proper-p-areasp data-seg)
		(definedp (lr-heap-name) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg)))
	   (equal (lr-max-node (car (lr-data-seg-table-body flag
							    body
							    data-seg
							    table)))
		  (lr-max-node data-seg)))
 ((use (same-signature-car-lr-data-seg-table-body
	(flag flag) (expr body) (data-seg data-seg) (table table)))
  (enable lr-max-node-same-signature)
  (disable lr-data-seg-table-body
	   same-signature-car-lr-data-seg-table-body)))

(prove-lemma SAME-SIGNATURE-CAR-LR-DATA-SEG-TABLE-LIST-HELPER (rewrite)
  (let ((dst-body (lr-data-seg-table-body t (s-body prog) data-seg table)))
    (implies (and (same-signature
		   (car dst-body)
		   (car (lr-data-seg-table-list progs
						(car dst-body)
						(cdr dst-body))))
		  (lr-proper-free-listp data-seg)
		  (lr-proper-p-areasp data-seg)
		  (definedp (lr-heap-name) data-seg)
		  (lr-boundary-nodep (lr-max-node data-seg)))
	     (same-signature
	      data-seg
	      (car (lr-data-seg-table-list progs
					   (car dst-body)
					   (cdr dst-body))))))
  ((use (transitivity-of-same-signature
	 (segment1 data-seg)
	 (segment2 (car (lr-data-seg-table-body t
						(s-body prog)
						data-seg
						table)))
	 (segment3 (car (lr-data-seg-table-list
			 progs
			 (car (lr-data-seg-table-body t
						      (s-body prog)
						      data-seg
						      table))
			 (cdr (lr-data-seg-table-body t
						      (s-body prog)
						      data-seg
						      table)))))))
  (disable lr-data-seg-table-body lr-data-seg-table-list)))

(prove-lemma SAME-SIGNATURE-CAR-LR-DATA-SEG-TABLE-LIST (rewrite)
  (implies (and (lr-proper-free-listp data-seg)
		(lr-proper-p-areasp data-seg)
		(definedp (lr-heap-name) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg)))
	   (same-signature data-seg
			   (car (lr-data-seg-table-list progs
							data-seg
							table))))
 ((induct (lr-data-seg-table-list progs data-seg table))
  (expand (lr-data-seg-table-list progs data-seg table))
  (disable-theory addition)
  (disable lr-data-seg-table-body lr-data-seg-table-list)))

(disable same-signature-car-lr-data-seg-table-list-helper)

(prove-lemma LENGTH-CAR-LR-COMPILE-QUOTE (rewrite)
  (implies (and (lr-proper-free-listp data-seg)
		(lr-proper-p-areasp data-seg)
		(definedp (lr-heap-name) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg)))
	   (equal (length (cdr (assoc name
				      (car (lr-compile-quote flag
							     object
							     data-seg
							     table)))))
		  (length (cdr (assoc name data-seg)))))
  ((enable equal-lengths-same-signature-car-lr-compile-quote
	   same-signature-car-lr-compile-quote)
   (disable lr-compile-quote)))

(prove-lemma LR-MAX-NODE-CAR-LR-COMPILE-QUOTE (rewrite)
  (implies (and (lr-proper-free-listp data-seg)
		(lr-proper-p-areasp data-seg)
		(definedp (lr-heap-name) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg)))
	   (equal (lr-max-node (car (lr-compile-quote flag
						      object
						      data-seg
						      table)))
		  (lr-max-node data-seg)))
  ((use (same-signature-car-lr-compile-quote
	 (flag flag) (object object) (data-seg data-seg) (table table)))
   (enable lr-max-node-same-signature)
   (disable lr-compile-quote)))

(prove-lemma LR-PROPER-FREE-LISTP-CAR-LR-INIT-DATA-SEG-TABLE (rewrite)
  (implies (and (lr-proper-free-listp data-seg)
		(lr-proper-p-areasp data-seg)
		(definedp (lr-heap-name) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg)))
	   (lr-proper-free-listp (car (lr-init-data-seg-table params
							      data-seg
							      table))))
 ((induct (lr-init-data-seg-table params data-seg table))
  (expand (lr-init-data-seg-table params data-seg table))
  (disable-theory addition)
  (disable lr-init-data-seg-table lr-compile-quote)))

(prove-lemma ADPP-UNTAG-LR-FP-ADDR-LR-INIT-DATA-SEG (rewrite)
  (adpp (identity (untag (lr-fp-addr))) (lr-init-data-seg heap-size)))

(prove-lemma LR-MAX-NODE-LR-INIT-DATA-SEG (rewrite)
  (implies (not (lessp heap-size 2))
	   (equal (lr-max-node (lr-init-data-seg heap-size))
		  (tag 'addr
		       (cons (identity (lr-heap-name))
			     (times (identity (lr-node-size)) heap-size)))))
  ((enable lr-max-node)
   (disable length lr-init-heap-contents
	    deposit-a-list-cons-opener)))

(prove-lemma FETCH-LR-FP-ADDR-LR-INIT-DATA-SEG (rewrite)
  (equal (fetch (identity (lr-fp-addr)) (lr-init-data-seg heap-size))
	 (identity (add-addr (lr-f-addr) (lr-node-size))))
  ((disable length lr-init-heap-contents
	    deposit-a-list-cons-opener)))

(prove-lemma LR-BOUNDARY-NODEP-NOT-LESSP-FACT-HELPER (rewrite)
  (implies (and (lessp x (times y z))
		(equal (remainder x y) 0)
		(numberp x))
	   (equal (lessp x (times y (sub1 z)))
		  (not (equal x (times y (sub1 z)))))))

(prove-lemma LESSP-TIMES-DIFFERENCE-FACT ()
  (implies (and (not (zerop z))
		(not (zerop x))
		(equal (remainder x y) 0))
	   (equal (lessp (difference x y) (times y (sub1 z)))
		  (lessp x (times y z)))))

(prove-lemma LESSP-TIMES-DIFFERENCE-NODE-ON-BOUNDARYP-FACT (rewrite)
  (implies (and (not (zerop heap-size))
		(not (zerop (offset addr)))
		(lr-boundary-nodep addr))
	   (equal (lessp (sub1 (sub1 (sub1 (sub1 (offset addr)))))
			 (times (identity (lr-node-size)) (sub1 heap-size)))
		  (lessp (offset addr)
			 (times (identity (lr-node-size)) heap-size))))
  ((enable lr-boundary-nodep)
   (use (lessp-times-difference-fact
	 (x (offset addr)) (y (lr-node-size)) (z heap-size)))))

(prove-lemma LR-BOUNDARY-NODEP-LESSP-LR-NODE-SIZE-0 (rewrite)
  (implies (lr-boundary-nodep addr)
	   (and (equal (equal (sub1 (offset addr)) 1) f)
		(equal (equal (sub1 (sub1 (offset addr))) 1) f)))
  ((enable lr-boundary-nodep)))

(prove-lemma LR-BOUNDARY-NODEP-LESSP-LR-NODE-SIZE-1 (rewrite)
  (implies (and (numberp (offset addr))
		(lr-boundary-nodep addr)
		(lessp n (lr-node-size)))
	   (equal (lessp n (offset addr)) (not (equal (offset addr) 0))))
  ((enable lr-boundary-nodep)))

(prove-lemma LR-BOUNDARY-NODEP-LESSP-LR-NODE-SIZE-2 (rewrite)
  (implies (lr-boundary-nodep addr)
	   (equal (equal (offset addr) 1) f))
  ((enable lr-boundary-nodep)))

(defn INDUCT-HINT-17 (addr1 size addr2)
  (if (zerop size)
      t
      (if (zerop (offset addr2))
	  t
	  (induct-hint-17 (add-addr addr1 (lr-node-size))
			  (sub1 size)
			  (sub-addr addr2 (lr-node-size))))))

(prove-lemma GET-CDR-LR-INIT-HEAP-CONTENTS (rewrite)
  (implies (and (lessp (offset addr2) (times (lr-node-size) heap-size))
		(lr-boundary-nodep addr2)
		(numberp (offset addr2))
		(numberp (offset addr1)))
	   (equal (get (offset addr2)
		       (cdr (lr-init-heap-contents addr1 heap-size)))
		  (add-addr (add-addr addr1 (offset addr2))
			    (lr-node-size))))
  ((induct (induct-hint-17 addr1 heap-size addr2))
   (enable commutativity-of-plus associativity-of-plus
	   get-cons)
   (expand (lr-init-heap-contents addr1 heap-size)
	   (get (sub1 (sub1 (sub1 (offset addr2))))
		(lr-init-heap-contents (add-addr addr1
						 (identity (lr-node-size)))
				       (sub1 heap-size))))
   (disable lr-init-heap-contents)))

(disable lr-boundary-nodep-lessp-lr-node-size-0)
(disable lr-boundary-nodep-lessp-lr-node-size-1)
(disable lr-boundary-nodep-lessp-lr-node-size-2)

(prove-lemma LENGTH-CDR-ASSOC-LR-HEAP-NAME-LR-INIT-DATA-SEG (rewrite)
  (implies (not (lessp heap-size 2))
	   (equal (length (cdr (assoc (identity (lr-heap-name))
				      (lr-init-data-seg heap-size))))
		  (add1 (times heap-size (identity (lr-node-size))))))
  ((enable commutativity-of-times)
   (disable lr-init-heap-contents
	    deposit-a-list-cons-opener)
   (disable-theory addition multiplication)))

(prove-lemma FETCH-ADD-ADDR-REF-COUNT-OFFSET-LR-INIT-DATA-SEG-HELP-1
    (rewrite)
  (implies (and (equal (offset addr) 0)
		(equal (type addr) 'addr)
		(equal (area-name addr) 'heap))
	   (equal (add-addr addr 4) '(addr (heap . 4))))
  ((enable add-addr area-name offset tag type)))

(prove-lemma EQUAL-ADD-ADDR-FACT (rewrite)
  (implies (equal (type addr1) (type addr2))
	   (equal (equal (add-addr addr1 n1) (add-addr addr2 n2))
		  (and (equal (area-name addr1) (area-name addr2))
		       (equal (plus (offset addr1) n1)
			      (plus (offset addr2) n2)))))
  ((use (adpp-area-name-offset-same (addr1 (add-addr addr1 n1))
				    (addr2 (add-addr addr2 n2))))))

(defn LR-ALL-NODES (min-offset max-addr)
  (if (zerop (offset max-addr))
      nil
      (if (not (lessp min-offset (offset max-addr)))
	  nil
	  (cons (sub-addr max-addr (lr-node-size))
		(lr-all-nodes min-offset
			      (sub-addr max-addr (lr-node-size))))))
  ((lessp (offset max-addr))))

(defn INDUCT-HINT-19 (addr max-addr)
  (if (lessp (offset addr) (offset max-addr))
      (induct-hint-19 (add-addr addr (lr-node-size))
		      max-addr)
      t)
  ((lessp (difference (offset max-addr) (offset addr)))))

(prove-lemma LESSP-TIMES-PLUS-FACT (rewrite)
  (implies (not (zerop n))
	   (equal (lessp (times n v) (plus n (times n w)))
		  (lessp v (add1 w)))))

(prove-lemma LESSP-SUB1-LESSP-FACT (rewrite)
  (implies (and (numberp x)
		(numberp y)
		(not (equal x 0))
		(not (equal x y)))
	   (equal (lessp (sub1 x) y)
		  (lessp x y))))

(prove-lemma REMAINDER-DIFFERENCE-NOT-EQUAL-LESSP-FACT ()
  (implies (and (equal (remainder x n) 0)
		(equal (remainder y n) 0)
		(not (equal x (difference y n)))
		(not (lessp y n))
		(numberp x)
		(numberp y))
	   (equal (lessp x (difference y n)) (lessp x y))))

(disable lessp-sub1-lessp-fact)

(prove-lemma LR-BOUNDARYP-NODEP-DIFFERENCE-NODE-SIZE ()
  (implies (lr-boundary-offsetp offset)
	   (lr-boundary-offsetp (difference offset (lr-node-size))))
  ((disable difference-add1-arg2)))

(prove-lemma LR-BOUNDARY-OFFSETP-DIFFERENCE-NOT-EQUAL-LESSP-FACT-1 ()
  (implies (and (lr-boundary-offsetp x)
		(lr-boundary-offsetp y)
		(not (equal x (difference y (lr-node-size))))
		(not (lessp y (lr-node-size)))
		(numberp x)
		(numberp y))
	   (equal (lessp x (difference y (lr-node-size))) (lessp x y)))
  ((use (remainder-difference-not-equal-lessp-fact
	 (x x) (y y) (n (lr-node-size))))
   (disable difference-add1-arg2)))

(prove-lemma MEMBER-LR-ALL-NODES-HELPER (rewrite)
  (implies (and (not (zerop (offset max-addr)))
		(numberp (offset addr))
		(equal (cddr addr) nil)
		(listp addr)
		(listp (untag addr))
		(lr-boundary-nodep addr)
		(lr-boundary-nodep max-addr)
		(equal (area-name addr) (area-name max-addr))
		(equal (type addr) (type max-addr))
		(not (equal addr (sub-addr max-addr (lr-node-size)))))
	   (equal (lessp (offset addr)
			 (sub1 (sub1 (sub1 (sub1 (offset max-addr))))))
		  (lessp (offset addr) (offset max-addr))))
  ((use (adpp-area-name-offset-same
	 (addr1 addr) (addr2 (sub-addr max-addr (lr-node-size))))
	(lr-boundary-offsetp-difference-not-equal-lessp-fact-1
	 (x (offset addr)) (y (offset max-addr)))
	(lr-boundaryp-nodep-difference-node-size
	 (offset (offset max-addr))))
   (enable lr-boundary-nodep)
   (disable lr-boundary-offsetp)))

(prove-lemma MEMBER-LR-ALL-NODES (rewrite)
  (implies (and (equal (type addr) 'addr)
		(equal (cddr addr) nil)
		(listp addr)
		(lr-boundary-nodep addr)
		(equal (area-name addr) (lr-heap-name))
		(listp (untag addr))
		(numberp (offset addr))
		(equal (type max-addr) 'addr)
		(equal (cddr max-addr) nil)
		(listp max-addr)
		(lr-boundary-nodep max-addr)
		(equal (area-name max-addr) (lr-heap-name))
		(listp (untag max-addr))
		(lr-boundary-offsetp min-offset)
		(not (lessp (offset addr) min-offset)))
	   (equal (member addr (lr-all-nodes min-offset max-addr))
		  (lessp (offset addr) (offset max-addr))))
  ((enable lr-boundary-nodep-lessp-lr-node-size-1)
   (induct (lr-all-nodes min-offset max-addr))
   (disable lr-boundary-offsetp
	    sub-addr-area-name-offset-same)))

(disable member-lr-all-nodes-helper)

(prove-lemma LR-ALL-NODES-NIL (rewrite)
  (equal (equal (lr-all-nodes min-offset max-addr) nil)
	 (or (zerop (offset max-addr))
	     (not (lessp min-offset (offset max-addr)))))
  ((expand (lr-all-nodes min-offset max-addr))))

(prove-lemma DELETE-APPEND (rewrite)
  (equal (delete e (append x y))
	 (if (member e x)
	     (append (delete e x) y)
	     (append x (delete e y)))))

(prove-lemma LESSP-DIFFERENCE-NODE-SIZE-SUB-ADDR-2 (rewrite)
  (implies (and (lessp offset (offset addr))
		(lr-boundary-nodep addr)
		(numberp (offset addr))
		(lr-boundary-offsetp offset))
	   (equal (lessp (difference (offset addr)
				     (identity (lr-node-size)))
			 offset)
		  f))
  ((disable-theory addition)
   (enable area-name lr-boundary-nodep offset sub-addr tag type untag)
   (use (lr-boundary-offsetp-difference-not-equal-lessp-fact-2
	 (x offset) (y (offset addr))))
   (disable lr-boundary-offsetp)))

(prove-lemma NOT-MEMBER-LR-ALL-NODES-TOO-SMALL-ADDR (rewrite)
  (implies (and (lr-boundary-nodep addr)
		(lr-boundary-nodep max-addr)
		(lr-boundary-offsetp min-offset)
		(lessp (offset addr) min-offset)
		(numberp min-offset))
	   (not (member addr (lr-all-nodes min-offset max-addr))))
  ((enable lr-boundary-nodep-lessp-lr-node-size-1)
   (induct (lr-all-nodes min-offset max-addr))
   (disable difference-add1-arg2)))

(prove-lemma PLIST-DELETE (rewrite)
  (equal (plist (delete e x)) (delete e (plist x))))

(prove-lemma LR-CHECK-FREE-NODES-PLIST-NODE-LIST (rewrite)
  (equal (lr-check-free-nodes addr (plist node-list) data-seg max-addr)
	 (lr-check-free-nodes addr node-list data-seg max-addr)))

(prove-lemma LR-ALL-NODES-OFFSET-SAME-MAX (rewrite)
  (equal (lr-all-nodes (offset addr) addr) nil))

(prove-lemma LR-ALL-NODES-OFFSET-MAX-ADDR-OPENER-HELPER (rewrite)
  (implies (and (not (zerop (offset addr)))
		(lr-boundary-nodep addr)
		(numberp offset)
		(lr-boundary-offsetp offset)
		(lessp offset (offset addr)))
	   (equal (lessp offset (sub1 (sub1 (sub1 (sub1 (offset addr))))))
		  (not (equal offset
			      (sub1 (sub1 (sub1 (sub1 (offset addr)))))))))
  ((enable area-name lr-boundary-nodep offset sub-addr tag type untag)))

(prove-lemma LR-ALL-NODES-LESSP-MAX-ADDR-OPENER (rewrite)
  (implies (and (equal (type max-addr) 'addr)
		(listp max-addr)
		(equal (cddr max-addr) nil)
		(listp (untag max-addr))
		(numberp (offset max-addr))
		(lr-boundary-nodep max-addr)
		(equal (area-name max-addr) (lr-heap-name))
		(lessp min-offset (offset max-addr))
		(numberp min-offset)
		(lr-boundary-offsetp min-offset))
	   (equal (lr-all-nodes min-offset max-addr)
		  (append (lr-all-nodes (plus min-offset
					      (identity (lr-node-size)))
					max-addr)
			  (list (tag 'addr
				     (cons (identity (lr-heap-name))
					   min-offset))))))
  ((enable lr-boundary-nodep-lessp-lr-node-size-0
	   lr-boundary-nodep-lessp-lr-node-size-1)
   (induct (lr-all-nodes min-offset max-addr))))

(prove-lemma FETCH-INIT-INIT-DATA-SEG-GENERALIZED (rewrite)
  (implies (and (numberp (offset addr))
		(equal (type addr) 'addr)
		(equal (cddr addr) nil)
		(listp addr)
		(listp (untag addr))
		(lr-boundary-nodep addr)
		(equal (area-name addr) (lr-heap-name))
		(lessp (offset addr)
		       (times (identity (lr-node-size)) heap-size))
		(equal (cdr (assoc (lr-heap-name) data-seg))
		       (lr-init-heap-contents (identity
					       (tag 'addr
						    (cons (lr-heap-name)
							  0)))
					      heap-size)))
	   (equal (fetch (add-addr addr (identity (lr-ref-count-offset)))
			 data-seg)
		  (add-addr addr 4)))
 ((enable fetch)
  (use (get-cdr-lr-init-heap-contents
	(addr1 (tag 'addr (cons (lr-heap-name) 0)))
	(heap-size heap-size)
	(addr2 addr)))
  (disable get-cdr-lr-init-heap-contents)))

(prove-lemma LESSP-DIFFERENCE-NODE-SIZE-SUB-ADDR-3 (rewrite)
  (implies (and (lessp (offset addr) (times (lr-node-size) heap-size))
		(lr-boundary-nodep addr)
		(numberp (offset addr)))
	   (equal (lessp (sub1 (sub1 (sub1 (sub1 (times (identity
							 (lr-node-size))
							heap-size)))))
			 (offset addr))
		  f))
  ((enable lr-boundary-nodep)
   (use (lr-boundary-offsetp-difference-not-equal-lessp-fact-2
	 (x (offset addr)) (y (times (lr-node-size) heap-size))))))

(prove-lemma LR-BOUNDARY-NODEP-TAG-CONS-TIMES-LR-NODE-SIZE (rewrite)
  (lr-boundary-nodep (tag x
			  (cons name
				(times (identity (lr-node-size))
				       heap-size))))
  ((enable lr-boundary-nodep)))

(prove-lemma TAG-TYPE-NAME-OFFSET-EQUAL-SAME (rewrite)
  (implies (and (equal (type addr) x)
		(equal (cddr addr) nil)
		(listp (untag addr))
		(numberp (offset addr))
		(equal (area-name addr) name))
	   (equal (tag x (cons name (offset addr))) addr))
  ((use (adpp-area-name-offset-same (addr1 (tag x (cons name (offset addr))))
				    (addr2 addr)))))

(prove-lemma LR-CHECK-FREE-NODES-LR-FREE-LIST-NODES-INIT-DATA-SEG ()
  (let ((init-data-seg
	 (list (cons (area-name (lr-fp-addr)) any1)
	       (cons (area-name (lr-answer-addr)) any2)
	       (cons (lr-heap-name)
		     (lr-init-heap-contents (tag 'addr
						 (cons (lr-heap-name) 0))
					    heap-size)))))
    (implies (and (not (lessp (offset max-addr) (offset addr)))
		  (equal (type addr) 'addr)
		  (equal (cddr addr) nil)
		  (listp addr)
		  (listp (untag addr))
		  (numberp (offset addr))
		  (lr-boundary-nodep addr)
		  (equal (area-name addr) (lr-heap-name))
		  (equal max-addr (lr-max-node init-data-seg)))
	     (lr-check-free-nodes addr
				  (lr-all-nodes (offset addr) max-addr)
				  (list (cons (identity
					       (area-name (lr-fp-addr)))
					      any1)
					(cons (identity
					       (area-name (lr-answer-addr)))
					      any2)
					(cons (identity (lr-heap-name))
					      (lr-init-heap-contents
					       (identity
						(tag 'addr
						     (cons (lr-heap-name)
							   0)))
					       heap-size)))
				  max-addr)))
  ((enable lr-max-node
	   associativity-of-plus commutativity-of-plus
	   adpp-untag-listp
	   adpp-untag-numberp-offset
	   lr-node-listp-delete
	   ;lr-boundary-nodep-plus
	   lr-boundary-nodep-lessp-lr-node-size-0)
   (induct (induct-hint-19 addr max-addr))
   (expand (lr-boundary-nodep addr))
   (disable lr-all-nodes lr-init-heap-contents)))

(disable fetch-init-init-data-seg-generalized)

(prove-lemma LR-FREE-LIST-NODES-DEPOSIT-A-LIST-LR-NODEP (rewrite)
  (implies (and (equal (type addr) 'addr)
		(equal (cddr addr) nil)
		(listp addr)
		(adpp (untag addr) data-seg)
		(lr-boundary-nodep addr)
		(equal (area-name addr) (lr-heap-name))
		(equal (type max-addr) 'addr)
		(equal (cddr max-addr) nil)
		(listp max-addr)
		(adpp (untag max-addr) data-seg)
		(lr-boundary-nodep max-addr)
		(equal (area-name max-addr) (lr-heap-name)))
	   (equal (lr-free-list-nodes max-addr
				      (deposit-a-list (list a b c d)
						      addr
						      data-seg))
		  (lr-free-list-nodes
		   max-addr
		   (deposit b
			    (add-addr addr
				      (identity (lr-ref-count-offset)))
			    data-seg))))
  ((enable adpp-deposit-anything-at-all
	   deposit-ref-count-move-inward-2)
   (disable lr-free-list-nodes
	    adpp-untag-add-addr-offset-car
	    adpp-untag-add-addr-offset-cdr
	    deposit-ref-count-move-outward
	    not-adpp-untag-add-addr-adpp-untag)))

(prove-lemma LR-CHECK-FREE-NODES-DEPOSIT-A-LIST-LR-NODEP (rewrite)
  (implies (and (equal (type addr) 'addr)
		(equal (cddr addr) nil)
		(listp addr)
		(adpp (untag addr) data-seg)
		(lr-boundary-nodep addr)
		(equal (area-name addr) (lr-heap-name))
		(equal (type max-addr) 'addr)
		(equal (cddr max-addr) nil)
		(listp max-addr)
		(adpp (untag max-addr) data-seg)
		(lr-boundary-nodep max-addr)
		(equal (area-name max-addr) (lr-heap-name))
		(lr-node-listp node-list data-seg))
	   (equal (lr-check-free-nodes addr1
				       node-list
				       (deposit-a-list (list a b c d)
						       addr
						       data-seg)
				       max-addr)
		  (lr-check-free-nodes addr1
				       node-list
				       (deposit
					b
					(add-addr addr
						  (identity (lr-ref-count-offset)))
					data-seg)
				       max-addr)))
  ((enable adpp-deposit-anything-at-all
	   deposit-ref-count-move-inward-2
	   lr-node-listp-deposit-anything-at-all)
   (disable lr-free-list-nodes
	    adpp-untag-add-addr-offset-car
	    adpp-untag-add-addr-offset-cdr
	    deposit-ref-count-move-outward
	    not-adpp-untag-add-addr-adpp-untag)))

(prove-lemma LR-ALL-NODES-NOT-LESSP-MIN-OFFSET-MAX-ADDR (rewrite)
  (implies (not (lessp min-offset (offset max-addr)))
	   (equal (lr-all-nodes min-offset max-addr) nil)))

(prove-lemma FETCH-INIT-INIT-DATA-SEG-SUB-ADDR (rewrite)
  (implies (and (not (lessp (times (identity (lr-node-size)) heap-size)
			    (offset addr)))
		(numberp (offset addr))
		(equal (cddr addr) nil)
		(listp addr)
		(listp (untag addr))
		(equal (type addr) 'addr)
		(lr-boundary-nodep addr)
		(equal (area-name addr) (lr-heap-name))
		(lessp (difference (offset addr) (identity (lr-node-size)))
		       (times (lr-node-size) heap-size))
		(not (equal (offset addr) 0))
		(equal (cdr (assoc (lr-heap-name) data-seg))
		       (lr-init-heap-contents (tag 'addr
						   (cons (lr-heap-name) 0))
					      heap-size)))
	   (equal (fetch (add-addr (sub-addr addr (identity (lr-node-size)))
				   (identity (lr-ref-count-offset)))
			 data-seg)
		  addr))
  ((use (fetch-init-init-data-seg-generalized
	 (addr (sub-addr addr (lr-node-size)))
	 (heap-size heap-size))
	(adpp-area-name-offset-same
	 (addr1 addr)
	 (addr2 (add-addr (sub-addr addr (lr-node-size)) (lr-node-size))))
	(lr-boundary-nodep-lessp-lr-node-size-1
	 (offset (offset addr)) (n (sub1 (lr-node-size)))))
   (disable difference-add1-arg2 plus-add1-arg2)
   (do-not-induct t)))

(prove-lemma LR-FREE-LIST-NODES-LR-INIT-HEAP-CONTENTS-GENERALIZED ()
  (implies (and (lr-boundary-nodep max-addr)
		(equal (area-name max-addr) (lr-heap-name))
		(equal (type max-addr) 'addr)
		(equal (cddr max-addr) nil)
		(listp max-addr)
		(listp (untag max-addr))
		(not (lessp (times (lr-node-size) heap-size)
			    (offset max-addr)))
		(equal (cdr (assoc (lr-heap-name) data-seg))
		       (lr-init-heap-contents (identity
					       (tag 'addr
						    (cons (lr-heap-name)
							  0)))
					      heap-size)))
	   (equal (lr-free-list-nodes max-addr data-seg)
		  (lr-all-nodes 0 max-addr)))
  ((disable difference-add1-arg2)
   (induct (lr-free-list-nodes max-addr data-seg))))

(prove-lemma LR-FREE-LIST-NODES-LR-INIT-HEAP-CONTENTS (rewrite)
  (implies (and (lr-boundary-nodep max-addr)
		(equal (area-name max-addr) (lr-heap-name))
		(equal (type max-addr) 'addr)
		(equal (cddr max-addr) nil)
		(listp max-addr)
		(listp (untag max-addr))
		(not (lessp (times (lr-node-size) heap-size)
			    (offset max-addr))))
	   (equal (lr-free-list-nodes
		   max-addr
		   (list (cons (identity (area-name (lr-fp-addr))) any1)
			 (cons (identity (area-name (lr-answer-addr))) any2)
			 (cons (identity (lr-heap-name))
			       (lr-init-heap-contents
				(identity (tag 'addr
					       (cons (lr-heap-name) 0)))
				heap-size))))
		  (lr-all-nodes 0 max-addr)))
  ((use (lr-free-list-nodes-lr-init-heap-contents-generalized
	 (max-addr max-addr) (heap-size heap-size)
	 (data-seg (list (cons (area-name (lr-fp-addr)) any1)
			 (cons (area-name (lr-answer-addr)) any2)
			 (cons (lr-heap-name)
			       (lr-init-heap-contents (tag 'addr
							   (cons
							    (lr-heap-name)
							    0))
						      heap-size))))))))

(prove-lemma LR-NODE-LISTP-LR-ALL-NODES (rewrite)
  (implies (and (lr-boundary-nodep addr)
		(equal (area-name addr) (lr-heap-name))
		(adpp (untag addr) data-seg)
		(equal (type addr) 'addr))
	   (lr-node-listp (lr-all-nodes min-offset addr)
			  data-seg))
  ((enable lr-node-listp)
   (disable difference-add1-arg2)))

(prove-lemma PLISTP-LR-ALL-NODES (rewrite)
  (plistp (lr-all-nodes min-offset max-addr)))

(prove-lemma LR-FREE-LIST-NODES-LR-INIT-DATA-SEG (rewrite)
  (implies (not (lessp heap-size 2))
	   (equal (lr-free-list-nodes (tag 'addr
					   (cons (identity (lr-heap-name))
						 (times (identity (lr-node-size))
							heap-size)))
				      (lr-init-data-seg heap-size))
		  (lr-all-nodes (identity
				 (offset (add-addr (lr-f-addr)
						   (lr-node-size))))
				(tag 'addr
				     (cons (identity (lr-heap-name))
					   (times (identity (lr-node-size))
						  heap-size))))))
  ((enable adpp-untag-listp)
   (disable lr-all-nodes lr-free-list-nodes lr-init-heap-contents
	    *1*add-addr
	    deposit-a-list-cons-opener
	    deposit-cons)))

(prove-lemma LR-PROPER-FREE-LISTP-LR-INIT-DATA-SEG-HELPER (rewrite)
  (implies (not (lessp heap-size 2))
	   (lr-check-free-nodes
	    (identity (add-addr (lr-f-addr) (lr-node-size)))
	    (lr-all-nodes (identity (offset (add-addr (lr-f-addr)
						      (lr-node-size))))
			  (tag 'addr (cons (identity (lr-heap-name))
					   (times (identity (lr-node-size))
						  heap-size))))
	    (lr-init-data-seg heap-size)
	    (tag 'addr
		 (cons (identity (lr-heap-name)) (times (identity (lr-node-size)) heap-size)))))
  ((enable lr-max-node
	   lr-check-free-nodes-delete-deposit
	   lr-node-listp-delete)
   (use (lr-check-free-nodes-lr-free-list-nodes-init-data-seg
	 (addr (add-addr (lr-f-addr) (lr-node-size)))
	 (max-addr (tag 'addr
			(cons (lr-heap-name)
			      (times (lr-node-size) heap-size))))
	 (any1 (list (add-addr (lr-f-addr) (lr-node-size))))
	 (any2 (list (tag 'nat 0)))
	 (heap-size heap-size)))
   (disable lr-check-free-nodes lr-free-list-nodes
	    lr-init-heap-contents
	    *1*add-addr
	    add-addr-add-addr
	    times
	    deposit-a-list-cons-opener
	    deposit-cons
	    lr-free-list-nodes-deposit-lr-ref-count-offset
	    times-1-arg1)
   (disable-theory addition)))

(prove-lemma LR-PROPER-FREE-LISTP-LR-INIT-DATA-SEG (rewrite)
  (implies (not (lessp heap-size 2))
	   (lr-proper-free-listp (lr-init-data-seg heap-size)))
  ((enable lr-proper-free-listp)
   (disable length lr-init-data-seg)
   (disable-theory addition)))

(prove-lemma DEFINEDP-LR-HEAP-NAME-LR-INIT-DATA-SEG (rewrite)
  (definedp (identity (lr-heap-name)) (lr-init-data-seg heap-size)))

(prove-lemma LR-PROPER-P-AREASP-LR-HEAP-NAME-LR-INIT-DATA-SEG (rewrite)
  (lr-proper-p-areasp (lr-init-data-seg heap-size)))

(prove-lemma LR-PROPER-P-AREASP-CAR-LR-INIT-DATA-SEG-TABLE (rewrite)
  (implies (lr-proper-p-areasp data-seg)
	   (lr-proper-p-areasp (car (lr-init-data-seg-table params
							    data-seg
							    table))))
  ((disable-theory addition)
   (disable lr-compile-quote)))

(prove-lemma LR-PROPER-P-AREASP-CAR-LR-DATA-SEG-TABLE-LIST (rewrite)
  (implies (lr-proper-p-areasp data-seg)
	   (lr-proper-p-areasp (car (lr-data-seg-table-list progs
							    data-seg
							    table))))
  ((disable-theory addition)
   (disable lr-data-seg-table-body)))

(prove-lemma DEFINEDP-TABLE-DEFINEDP-CAR-LR-INIT-DATA-SEG-TABLE (rewrite)
  (equal (definedp name (car (lr-init-data-seg-table params data-seg table)))
	 (definedp name data-seg))
  ((disable-theory addition)
   (disable lr-compile-quote)))

(prove-lemma ALL-P-OBJECTS-LOOKUP-CONS-TABLE (rewrite)
  (implies (and (all-p-objects-lookup list table p)
		(p-objectp y p))
	   (all-p-objects-lookup list (cons (cons x y) table) p)))

(prove-lemma P-OBJECTP-OPENER-ALT-LR-PROPER-FREE-LISTP (rewrite)
  (implies (and (lr-proper-free-listp (p-data-segment p))
		(adpp (untag (lr-max-node data-seg)) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg))
		(equal data-seg (p-data-segment p)))
	   (p-objectp (fetch (identity (lr-fp-addr)) data-seg) p)))

(prove-lemma P-OBJECTP-LOOKUP-DEPOSIT-A-LIST (rewrite)
  (implies (p-objectp object (p-state pc
				     ctrl-stk
				     temp-stk
				     prog-seg
				     data-seg
				     max-ctrl-stk-size
				     max-temp-stk-size
				     word-size
				     psw))
	   (p-objectp object (p-state pc
				     ctrl-stk
				     temp-stk
				     prog-seg
				     (deposit-a-list stuff addr data-seg)
				     max-ctrl-stk-size
				     max-temp-stk-size
				     word-size
				     psw)))
  ((enable p-objectp)))

(prove-lemma ALL-P-OBJECTS-LOOKUP-DEPOSIT-A-LIST (rewrite)
  (implies (all-p-objects-lookup list
				 table
				 (p-state pc
					  ctrl-stk
					  temp-stk
					  prog-seg
					  data-seg
					  max-ctrl-stk-size
					  max-temp-stk-size
					  word-size
					  psw))
	   (all-p-objects-lookup list
				 table
				 (p-state pc
					  ctrl-stk
					  temp-stk
					  prog-seg
					  (deposit-a-list stuff
							  addr
							  data-seg)
					  max-ctrl-stk-size
					  max-temp-stk-size
					  word-size
					  psw))))

(prove-lemma P-OBJECTP-LOOKUP-DEPOSIT (rewrite)
  (implies (p-objectp object (p-state pc
				     ctrl-stk
				     temp-stk
				     prog-seg
				     data-seg
				     max-ctrl-stk-size
				     max-temp-stk-size
				     word-size
				     psw))
	   (p-objectp object (p-state pc
				     ctrl-stk
				     temp-stk
				     prog-seg
				     (deposit anything addr data-seg)
				     max-ctrl-stk-size
				     max-temp-stk-size
				     word-size
				     psw)))
  ((enable p-objectp
	   adpp-deposit-anything-at-all)))

(prove-lemma ALL-P-OBJECTS-LOOKUP-DEPOSIT (rewrite)
  (implies (all-p-objects-lookup list
				 table
				 (p-state pc
					  ctrl-stk
					  temp-stk
					  prog-seg
					  data-seg
					  max-ctrl-stk-size
					  max-temp-stk-size
					  word-size
					  psw))
	   (all-p-objects-lookup list
				 table
				 (p-state pc
					  ctrl-stk
					  temp-stk
					  prog-seg
					  (deposit anything addr data-seg)
					  max-ctrl-stk-size
					  max-temp-stk-size
					  word-size
					  psw))))

(prove-lemma DEFINEDP-NAME-P-OBJECTP-TAG-0-LR-PROPER-P-AREASP (rewrite)
  (implies (lr-proper-p-areasp data-seg)
	   (equal (p-objectp (list 'addr (cons name 0))
			     (p-state pc
				      ctrl-stk
				      temp-stk
				      prog-seg
				      data-seg
				      max-ctrl-stk-size
				      max-temp-stk-size
				      word-size
				      psw))
		  (definedp name data-seg)))
  ((enable adpp type untag
	   definedp-listp-cdr-assoc-lr-proper-p-areasp)))

(prove-lemma ALL-P-OBJECTS-LOOKUP-LR-COMPILE-QUOTE (rewrite)
  (implies (and (all-p-objects-lookup list
				      table
				      (p-state pc
					       ctrl-stk
					       temp-stk
					       prog-seg
					       data-seg
					       max-ctrl-stk-size
					       max-temp-stk-size
					       word-size
					       psw))
		(lr-proper-free-listp data-seg)
		(lr-proper-p-areasp data-seg)
		(definedp (lr-heap-name) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg)))
	   (all-p-objects-lookup list
				 (cdr (lr-compile-quote flag
							object
							data-seg
							table))
				 (p-state pc
					  ctrl-stk
					  temp-stk
					  prog-seg
					  (car (lr-compile-quote flag
								 object
								 data-seg
								 table))
					  max-ctrl-stk-size
					  max-temp-stk-size
					  word-size
					  psw)))
  ((induct (lr-compile-quote flag object data-seg table))
   (expand (lr-compile-quote flag object data-seg table)
	   (lr-compile-quote 'list object data-seg table)
	   (lr-compile-quote flag t data-seg table))
   (disable-theory addition)
   (disable lr-compile-quote
	    deposit-a-list-cons-opener
	    definedp-table-definedp-cdr-lr-compile-quote
	    lr-proper-free-listp-opener-2-adpp-untag-numberp-offset
	    lr-proper-heapp-opener-1 lr-proper-heapp-opener-4
	    p-objectp-cdr-assoc-bindings-proper-p-alistp
	    p-objectp-opener)))

(prove-lemma ALL-P-OBJECTS-LOOKUP-LR-DATA-SEG-TABLE-BODY (rewrite)
  (implies (and (all-p-objects-lookup list
				      table
				      (p-state pc
					       ctrl-stk
					       temp-stk
					       prog-seg
					       data-seg
					       max-ctrl-stk-size
					       max-temp-stk-size
					       word-size
					       psw))
		(lr-proper-free-listp data-seg)
		(lr-proper-p-areasp data-seg)
		(definedp (lr-heap-name) data-seg)
		(lr-boundary-nodep (lr-max-node data-seg)))
	   (all-p-objects-lookup list
				 (cdr (lr-data-seg-table-body flag
							      body
							      data-seg
							      table))
				 (p-state pc
					  ctrl-stk
					  temp-stk
					  prog-seg
					  (car (lr-data-seg-table-body
						flag
						body
						data-seg
						table))
					  max-ctrl-stk-size
					  max-temp-stk-size
					  word-size
					  psw)))
  ((induct (lr-data-seg-table-body flag body data-seg table))
   (expand (lr-data-seg-table-body flag body data-seg table)
	   (lr-data-seg-table-body 'list body data-seg table))
   (di