;;; -*- 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)))