;;; -*- Mode:LISP; Base:10; Readtable:ZL -*-


(defun foo (a)
  (bar a))

(defconstant *c* 'five)
(defvar *v*)
(defconst *cc* 'seven)
(defun foo-1 (*v*)
  (bar *cc*))


(defun foo-2 (*v* &optional (b *v*))
  (bar *v*))


(defun yuck (x)
  (+ x 'b))

(defun parallel-bind-test-1 ()
  (let ((a 3)
	(b 4))
    (print (list a b))))

(defun parallel-bind-test-2 ()
  (let ((a 7))
;    (print a)
    (let ((a 3)
	  (b a)
	  (c 5))
      (declare (special b))
;    (print c)
      (print (list a b c)))))


;;; This has the potential to lose open frames from the pool if we aren't
;;; careful to return them when returning out from where they were started.

;;; The Hardebeck compiler loses totally on this one.  It never even calls
;;; FOO or tests FLAG, it just allocates two frames, deallocates them, and
;;; unconditionally returns 'LOSE.  Damfino why it opens TWO frames; only
;;; one is needed even if FLAG is NIL.

(defun return-test (flag)
  (block foo
    (foo 3 (if flag
	       (return-from foo 'lose)
	     2))))



;;; This has to clean up a tail-open.  To do this, we do:
;;; (TAIL-CALL (0 0) NIL NEXT-PC-PC+1)
;;; (TAIL-OPEN-CALL (0 0) NIL NEXT-PC-PC+1)
;;; The analysis is:
;;;                   O A R
;;; Initial state:    A A R  ; O had better have the same as A, on *ANY* tail-call.
;;; Tail open:        F A R  ; F is new from heap.
;;; Tail open:        F F A  ; R goes to heap.
;;; Tail open-call:   A A F  ; Once again in a valid state; with a different R reg.

;;; The Hardebeck compiler loses on this by returning the value of the CONS.
;;; TAGBODY returns NIL.

(defun tail-punt (flag)
  (tagbody loop
      (cons 'a (when flag (go loop)))))

(defun multiple-value-test-1 (a b c)
  (values a b c))

(defun multiple-value-return-out-andor (flag)
 (values (foo 1)
	 (when flag (return-from multiple-value-return-out-andor 8))
	 (bar 2)
	 (baz 3)))

;;; The Hardebeck compiler blows out on this, with the wrong number
;;; of args in REG-ALLOC.

(defun multiple-value-return-out-to-block-andor (flag)
  (let ((yow (block yow-block
	       (values (foo 1)
		       (when flag (return-from yow-block 8))
		       (bar 2)
		       (baz 3)))))
    yow))

(defun prog1-return-out-to-block-andor (flag)
  (let ((yow (block yow-block
	       (prog1 (foo 1)
		      (when flag (return-from yow-block 8))
		      (bar 2)
		      (baz 3)))))
    (yow yow)))

(defvar *special*)

(defun let-return-out-to-block-andor-bad-o0 (flag)
  (+ 5
     (let ((yow (block yow
		  (let ((*special* 3))
		    (when flag (return-from yow 8))
		    (bar 2)
		    (baz 3)))))
       (yow yow))))


(defun multiple-value-return-out-andor-simpler (flag)
 (values 
   (baz 3)
   (when flag (return-from multiple-value-return-out-andor-simpler 8))))


(defun throw-multiple-value (a b c)
  (throw 'foo (values a b c)))

(defun catch-throw-multiple-value (a b c)
  (catch 'foo
    (throw-multiple-value a b c)))


(defun many-arguments-return-out (flag)
  (foo 0 1 2 3 4 5 6 7 7 8 9 10 11 12 13 14 15 'stack-0 'stack-1
       (when flag (return-from many-arguments-return-out nil))))

(defun multiple-value-bind-test ()
  (multiple-value-bind (a b c)
      (foo)
    (list a b c)))

(defun many-arguments-function (a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 stack0 stack1)
  (list (list a0 a1 a2 a3 a4 a5 a6 a7)
	(list a8 a9 a10 a11 a12 a13 a14 a15)
	(list stack0 stack1)))


;;; The Hardebeck compiler screws up on this case and doesn't run most
;;; of the code.
(defun unwind-protect-branch-out (x)
  (tagbody
      (return-from unwind-protect-branch-out
	(unwind-protect (progn (frob x) (frob x x)
			       (if x (go exit)))
	  (fixup x)))
      exit))

;;; The Hardebeck compiler screws up on this case and doesn't run most
;;; of the code.
(defun unwind-protect-return-out (x)
  (unwind-protect (progn (frob x) (frob x x)
			 (if x (return-from unwind-protect-return-out 5)))
    (fixup x)))

;;; The Hardebeck compiler makes no attempt to do UNWIND-PROTECT at all!
(defun unwind-protect-simple (x)
  (unwind-protect (progn (frob x) (frob x x)
			 5)
    (fixup x)))


;;; The Hardebeck compiler screws up on this case.
;;; (But not with the problem this is designed to detect).
(defun tagbody-conflict (x)
  (tagbody
      tag
	 (tagbody tag
	     (if x (go tag)))
	 (go tag)))


(defun simple-return-closure (var)
  #'(lambda () var))

(defun labels-return-closure (var)
  (labels ((closure-1 () #'closure-2)
	   (closure-2 () #'closure-1))
    #'closure-2))