;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
;; ALL RIGHTS RESERVED.
;;
;; $Id: must-data-and-control.lisp,v 1.15 2004/02/20 07:23:42 yuji Exp $
;; 
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 
;;  * Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;;  * Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in
;;    the documentation and/or other materials provided with the
;;    distribution.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(let (a b c)
  (and (null (psetq a 1 b 2 c 3))
       (eql a 1)
       (eql b 2)
       (eql c 3)))

(let ((a 1)
      (b 2)
      (c 3))
  (and (null (psetq a (1+ b) b (1+ a) c (+ a b)))
       (eql a 3)
       (eql b 2)
       (eql c 3)))

(let ((x (list 10 20 30)))
  (symbol-macrolet ((y (car x)) (z (cadr x)))
    (psetq y (1+ z) z (1+ y))
    (equal (list x y z) '((21 11 30) 21 11))))

(let ((a 1) (b 2))
  (and (null (psetq a b  b a))
       (eql a 2)
       (eql b 1)))


(null (psetq))
(let ((a nil))
  (and (null (psetq a t))
       (eq a t)))
(let ((a 0)
      (b 1))
  (and (null (psetq a b
		    b a))
       (eq a 1)
       (eq b 0)))

(let ((a 0)
      (b 1)
      (c 2))
  (and (null (psetq a b
		    b c
		    c a))
       (eq a 1)
       (eq b 2)
       (eq c 0)))

(let ((a 0)
      (b 1)
      (c 2)
      (d 3))
  (and (null (psetq a b
		    b c
		    c d
		    d a))
       (eq a 1)
       (eq b 2)
       (eq c 3)
       (eq d 0)))



(null (block nil (return) 1))
(eql (block nil (return 1) 2) 1)
(equal (multiple-value-list (block nil (return (values 1 2)) 3)) '(1 2))
(eql (block nil (block alpha (return 1) 2)) 1)
(eql (block alpha (block nil (return 1)) 2) 2)
(eql (block nil (block nil (return 1) 2)) 1)

(eq (dotimes (i 10 nil)
      (return t))
    t)

(eq (dolist (elt (list 0 1 2 3) nil)
      (when (numberp elt)
	(return t)))
    t)

(not nil)
(not '())
(not (integerp 'sss))
(null (not (integerp 1)))
(null (not 3.7))
(null (not 'apple))

(not nil)
(null (not t))
(not (cdr '(a)))


(equal 'a 'a)
(not (equal 'a 'b))
(equal 'abc 'abc)
(equal 1 1)
(equal 2 2)
(equal 0.1 0.1)
(equal 1/3 1/3)
(not (equal 0 1))
(not (equal 1 1.0))
(not (equal 1/3 1/4))
(equal #\a #\a)
(equal #\b #\b)
(not (equal #\b #\B))
(not (equal #\C #\c))
(equal '(0) '(0))
(equal '(0 #\a) '(0 #\a))
(equal '(0 #\a x) '(0 #\a x))
(equal '(0 #\a x (0)) '(0 #\a x (0)))
(equal '(0 #\a x (0 (#\a (x "abc" #*0101))))
       '(0 #\a x (0 (#\a (x "abc" #*0101)))))
(not (equal (make-array '(2 2) :initial-contents '((a b) (c d)))
	    (make-array '(2 2) :initial-contents '((a b) (c d)))))
(let ((array (make-array '(2 2) :initial-contents '((a b) (c d)))))
  (equal array array))


(eql (identity 101) 101)
(equal (mapcan #'identity (list (list 1 2 3) '(4 5 6))) '(1 2 3 4 5 6))
(eq (identity 'x) 'x)



(funcall (complement #'zerop) 1)
(not (funcall (complement #'characterp) #\A))
(not (funcall (complement #'member) 'a '(a b c)))
(funcall (complement #'member) 'd '(a b c))



(equal (mapcar (constantly 3) '(a b c d)) '(3 3 3 3))
(let ((const-func (constantly 'xyz)))
  (every #'(lambda (arg) (eq arg 'xyz))
	 (list (funcall const-func)
	       (funcall const-func 'a)
	       (funcall const-func 'a 'b)
	       (funcall const-func 'a 'b 'c)
	       (funcall const-func 'a 'b 'c 'd))))



(let ((temp1 1)
      (temp2 1)
      (temp3 1))
  (and (eql (and (incf temp1) (incf temp2) (incf temp3)) 2)
       (and (eql 2 temp1) (eql 2 temp2) (eql 2 temp3))
       (eql (decf temp3) 1)
       (null (and (decf temp1) (decf temp2) (eq temp3 'nil) (decf temp3)))
       (and (eql temp1 temp2) (eql temp2 temp3))
       (and)))

(eq (and) t)
(equal (multiple-value-list (and 't 't 't (values 'a 'b 'c)))
       '(a b c))
(null (and 't 't (cdr '(a)) (error "error")))



(let ((temp0 nil)
      (temp1 10)
      (temp2 20)
      (temp3 30))
  (and (eql (or temp0 temp1 (setq temp2 37)) 10)
       (eql temp2 20)
       (eql (or (incf temp1) (incf temp2) (incf temp3)) 11)
       (eql temp1 11)
       (eql temp2 20)
       (eql temp3 30)
       (equal (multiple-value-list (or (values) temp1)) '(11))
       (equal (multiple-value-list (or (values temp1 temp2) temp3)) '(11))
       (equal (multiple-value-list (or temp0 (values temp1 temp2))) '(11 20))
       (equal (multiple-value-list (or (values temp0 temp1)
				       (values temp2 temp3)))
	      '(20 30))))

(zerop (or '0 '1 '2))
(let ((a 0))
  (and (eql (or (incf a) (incf a) (incf a)) 1)
       (eql a 1)))
(equal (multiple-value-list (or (values) 1)) '(1))
(equal (multiple-value-list (or (values 1 2) 3)) '(1))

(null (or))
(equal (multiple-value-list (or (values 0 1 2))) '(0 1 2))
(equal (multiple-value-list (or nil (values 0 1 2))) '(0 1 2))
(equal (multiple-value-list (or nil nil (values 0 1 2))) '(0 1 2))
(equal (multiple-value-list (or nil nil nil (values 0 1 2))) '(0 1 2))


(let ((a nil))
  (flet ((select-options ()
           (cond ((= a 1) (setq a 2))
		 ((= a 2) (setq a 3))
		 ((and (= a 3) (floor a 2)))
		 (t (floor a 3)))))
    (and (eql (setq a 1) 1)
	 (eql (select-options) 2)
	 (eql a 2)
	 (eql (select-options) 3)
	 (eql a 3)
	 (eql (select-options) 1)
	 (setq a 5)
	 (equal (multiple-value-list (select-options)) '(1 2)))))

(null (cond))
(equal (multiple-value-list (cond ((values 1 2 3)))) '(1))
(equal (multiple-value-list (cond (t (values 1 2 3)))) '(1 2 3))
(equal (multiple-value-list (cond (t (values 1)
				     (values 1 2)
				     (values 1 2 3)))) '(1 2 3))
(let ((a 0))
  (and (eql (cond
	     ((incf a))
	     ((incf a))
	     ((incf a)))
	    1)
       (eql a 1)))

(let ((a 0))
  (and (eql (cond
	     ((incf a) (incf a) (incf a))
	     ((incf a) (incf a) (incf a))
	     ((incf a) (incf a) (incf a)))
	    3)
       (eql a 3)))



(eq (when t 'hello) 'HELLO)
(null (unless t 'hello))
(null (when nil 'hello))
(eq (unless nil 'hello) 'HELLO)
(null (when t))
(null (unless nil))
(let ((x 3))
  (equal (list (when (oddp x) (incf x) (list x))
	       (when (oddp x) (incf x) (list x))
	       (unless (oddp x) (incf x) (list x))
	       (unless (oddp x) (incf x) (list x))
	       (if (oddp x) (incf x) (list x)) 
	       (if (oddp x) (incf x) (list x)) 
	       (if (not (oddp x)) (incf x) (list x)) 
	       (if (not (oddp x)) (incf x) (list x)))
	 '((4) NIL (5) NIL 6 (6) 7 (7))))




(equal (let ((list nil))
	 (dolist (k '(1 2 3 :four #\v () t 'other))
	   (push (case k
		   ((1 2) 'clause1)
		   (3 'clause2)
		   (nil 'no-keys-so-never-seen)
		   ((nil) 'nilslot)
		   ((:four #\v) 'clause4)
		   ((t) 'tslot)
		   (otherwise 'others))
		 list))
	 list)
       '(OTHERS TSLOT NILSLOT CLAUSE4 CLAUSE4 CLAUSE2 CLAUSE1 CLAUSE1))


(macro-function 'case)
(macro-function 'ccase)
(macro-function 'ecase)

(eql (case 'a
       ((a b c) 0)
       (x 1)
       (y 2)
       (z 3))
     0)

(eql (case 'j
       ((a b c) 0)
       (x 1)
       (y 2)
       (z 3)
       (t 9))
     9)

(eql (case 'j
       ((a b c) 0)
       (x 1)
       (y 2)
       (z 3)
       (otherwise 9))
     9)

(eql (case 'j
       ((a b c) 0)
       (x 1)
       (y 2)
       (z 3))
     nil)

(null (case 'x))

(let ((x #\a))
  (equal (case x
	   ((#\x #\y #\z) "xyz")
	   (#\a "a")
	   (t "-"))
	 "a"))

(let ((x #\A))
  (equal (case x
	   ((#\x #\y #\z) "xyz")
	   (#\a "a")
	   (t "-"))
	 "-"))

(let ((x t))
  (eql (case x
	 ((t) 0)
	 (t 1))
       0))

(let ((x nil))
  (eql (case x
	 ((t) 0)
	 (t 1))
       1))

(let ((x 'a))
  (eql (case x
	 ((t) 0))
       nil))

(let ((x 'otherwise))
  (eql (case x
	 ((otherwise) 0)
	 (otherwise 1))
       0))

(let ((x nil))
  (eql (case x
	 ((otherwise) 0)
	 (otherwise 1))
       1))

(let ((x 'a))
  (eql (case x
	 ((otherwise) 0))
       nil))


(let ((x 'a))
  (and (eql (case x
	      ((a b c) (setq x 0) 'a)
	      ((x y z) (setq x 1) 'x))
	    'a)
       (eql x 0)))

(let ((x 'x))
  (and (eql (case x
	      ((a b c) (setq x 0) 'a)
	      ((x y z) (setq x 1) 'x))
	    'x)
       (eql x 1)))


(equal (mapcar #'(lambda (x)  (case x (a 0) (b 1) (c 2) (d 3) (e 4)))
	       '(a b c d e f))
       '(0 1 2 3 4 nil))

(case 'a (otherwise t))

(eql (case 'a (otherwise 10)) 10)

(let ((a 0)
      (b 1))
  (and (eq (case (progn (incf a) (incf b))
	     (0 'a)
	     (1 'b)
	     (2 'c))
	   'c)
       (eql a 1)
       (eql b 2)))

(let ((a 0)
      (b 1))
  (and (eq (case (progn (incf a) (incf b))
	     (0 'a)
	     (1 'b)
	     (2 (incf a) (incf b) 'c))
	   'c)
       (eql a 2)
       (eql b 3)))

(let ((a (list 0 1 2 3)))
  (eq (case (caddr a)
	(0 'x)
	(1 'y)
	(2 'z)
	(3 t))
      'z))


(equal (multiple-value-list (case 2
			      (0 (values 0 'x))
			      (1 (values 1 'y))
			      (2 (values 2 'z))
			      (3 (values 3 't))))
       '(2 z))



(let ((a 'c))
  (eql (ccase a
         ((a b c) 0)
	 (x 1)
	 (y 2)
	 (z 3))
       0))

(HANDLER-CASE
    (PROGN
      (LET ((A 'J))
	(CCASE A ((A B C) 0) (X 1) (Y 2) (Z 3))))
  (TYPE-ERROR NIL T)
  (ERROR NIL NIL)
  (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))

(HANDLER-CASE
    (PROGN
      (LET ((A NIL))
	(CCASE A)))
  (TYPE-ERROR NIL T)
  (ERROR NIL NIL)
  (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))

(HANDLER-CASE
    (PROGN
      (LET ((A #\a))
	(CCASE A ((#\A #\B #\C) 0) ((#\X #\Y #\Z) 1))))
  (TYPE-ERROR NIL T)
  (ERROR NIL NIL)
  (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))

(let ((a (list 0 1 2 3)))
  (eq (ccase (caddr a)
	     (0 'x)
	     (1 'y)
	     (2 'z)
	     (3 t))
      'z))

(let ((x #\a))
  (equal (ccase x
		((#\x #\y #\z) "xyz")
		(#\a "a"))
	 "a"))

(let ((x 'a))
  (and (eql (ccase x
		   ((a b c) (setq x 0) 'a)
		   ((x y z) (setq x 1) 'x))
	    'a)
       (eql x 0)))

(let ((x 'x))
  (and (eql (ccase x
		   ((a b c) (setq x 0) 'a)
		   ((x y z) (setq x 1) 'x))
	    'x)
       (eql x 1)))

(equal (mapcar #'(lambda (x)  (ccase x (a 0) (b 1) (c 2) (d 3) (e 4)))
	       '(a b c d e))
       '(0 1 2 3 4))


(equal (multiple-value-list (let ((a 2))
			      (ccase a
				     (0 (values 0 'x))
				     (1 (values 1 'y))
				     (2 (values 2 'z))
				     (3 (values 3 't)))))
       '(2 z))

(let ((a 'c))
  (eql (ecase a
         ((a b c) 0)
	 (x 1)
	 (y 2)
	 (z 3))
       0))

(HANDLER-CASE
    (PROGN
      (LET ((A 'J))
	(ECASE A ((A B C) 0) (X 1) (Y 2) (Z 3))))
  (TYPE-ERROR NIL T)
  (ERROR NIL NIL)
  (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))

(HANDLER-CASE
    (PROGN
      (LET ((A NIL))
	(ECASE A)))
  (TYPE-ERROR NIL T)
  (ERROR NIL NIL)
  (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))

(HANDLER-CASE
    (PROGN
      (LET ((A #\a))
	(ECASE A ((#\A #\B #\C) 0) ((#\X #\Y #\Z) 1))))
  (TYPE-ERROR NIL T)
  (ERROR NIL NIL)
  (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))

(let ((a (list 0 1 2 3)))
  (eq (ecase (caddr a)
	     (0 'x)
	     (1 'y)
	     (2 'z)
	     (3 t))
      'z))

(let ((x #\a))
  (equal (ecase x
		((#\x #\y #\z) "xyz")
		(#\a "a"))
	 "a"))

(let ((x 'a))
  (and (eql (ecase x
		   ((a b c) (setq x 0) 'a)
		   ((x y z) (setq x 1) 'x))
	    'a)
       (eql x 0)))

(let ((x 'x))
  (and (eql (ecase x
		   ((a b c) (setq x 0) 'a)
		   ((x y z) (setq x 1) 'x))
	    'x)
       (eql x 1)))

(equal (mapcar #'(lambda (x)  (ecase x (a 0) (b 1) (c 2) (d 3) (e 4)))
	       '(a b c d e))
       '(0 1 2 3 4))

(equal (multiple-value-list (let ((a 2))
			      (ecase a
				(0 (values 0 'x))
				(1 (values 1 'y))
				(2 (values 2 'z))
				(3 (values 3 't)))))
       '(2 z))


(let ((x 'a))
  (equal (typecase x
	   (cons "cons")
	   (symbol "symbol")
	   (number "number")
	   (otherwise "unknown"))
	 "symbol"))

(let ((x (list 'a)))
  (equal (typecase x
	   (cons "cons")
	   (symbol "symbol")
	   (number "number")
	   (otherwise "unknown"))
	 "cons"))

(let ((x 0))
  (equal (typecase x
	   (cons "cons")
	   (symbol "symbol")
	   (number "number")
	   (otherwise "unknown"))
	 "number"))

(let ((x (make-array '(3 3))))
  (equal (typecase x
	   (cons "cons")
	   (symbol "symbol")
	   (number "number")
	   (otherwise "unknown"))
	 "unknown"))


(null (typecase 'a))
(typecase 'a (otherwise t))
(typecase 'a (t t))

(let ((x (make-array '(3 3))))
  (equal (typecase x
	   (cons "cons")
	   (symbol "symbol")
	   (number "number"))
	 nil))

(let ((x ""))
  (equal (typecase x
	   (t "anything")
	   (otherwise nil))
	 "anything"))

(let ((x ""))
  (and (eql (typecase x
	      (string (setq x 'string) 0)
	      (cons (setq x 'cons) 1)
	      (array (setq x 'array) 2)
	      (t (setq x 't) 9))
	    0)
       (eq x 'string)))

(let ((x (list nil)))
  (and (eql (typecase x
	      (string (setq x 'string) 0)
	      (cons (setq x 'cons) 1)
	      (array (setq x 'array) 2)
	      (t (setq x 't) 9))
	    1)
       (eq x 'cons)))


(let ((x #*01))
  (and (eql (typecase x
	      (string (setq x 'string) 0)
	      (cons (setq x 'cons) 1)
	      (array (setq x 'array) 2)
	      (t (setq x 't) 9))
	    2)
       (eq x 'array)))

(let ((x #\a))
  (and (eql (typecase x
	      (string (setq x 'string) 0)
	      (cons (setq x 'cons) 1)
	      (array (setq x 'array) 2)
	      (t (setq x 't) 9))
	    9)
       (eq x 't)))

(let ((x #*01))
  (and (equal (multiple-value-list (typecase x
				     (string (setq x 'string) (values 'string 0))
				     (cons (setq x 'cons) (values 'cons 1))
				     (array (setq x 'array) (values 'array 2))
				     (t (setq x 't) (values 't 9))))
	      '(array 2))
       (eq x 'array)))


(let ((x 'a))
  (equal (ctypecase x
	   (cons "cons")
	   (symbol "symbol")
	   (number "number"))
	 "symbol"))

(let ((x (list 'a)))
  (equal (ctypecase x
	   (cons "cons")
	   (symbol "symbol")
	   (number "number"))
	 "cons"))

(let ((x 0))
  (equal (ctypecase x
	   (cons "cons")
	   (symbol "symbol")
	   (number "number"))
	 "number"))

(HANDLER-CASE
    (LET ((X (MAKE-ARRAY '(3 3))))
      (CTYPECASE X
	(CONS "cons")
	(SYMBOL "symbol")
	(NUMBER "number")))
  (TYPE-ERROR NIL T)
  (ERROR NIL NIL)
  (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))


(HANDLER-CASE
    (LET ((A NIL)) (CTYPECASE A))
  (TYPE-ERROR NIL T)
  (ERROR NIL NIL)
  (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))

;; (let ((x ""))
;;   (equal (ctypecase x (t "anything"))
;; 	    "anything"))

(let ((x ""))
  (and (eql (ctypecase x
	      (string (setq x 'string) 0)
	      (cons (setq x 'cons) 1)
	      (array (setq x 'array) 2))
	    0)
       (eq x 'string)))

(let ((x (list nil)))
  (and (eql (ctypecase x
	      (string (setq x 'string) 0)
	      (cons (setq x 'cons) 1)
	      (array (setq x 'array) 2))
	    1)
       (eq x 'cons)))


(let ((x #*01))
  (and (eql (ctypecase x
	      (string (setq x 'string) 0)
	      (cons (setq x 'cons) 1)
	      (array (setq x 'array) 2))
	    2)
       (eq x 'array)))

;; (let ((x #\a))
;;   (and (eql (ctypecase x
;; 		 (string (setq x 'string) 0)
;; 		 (cons (setq x 'cons) 1)
;; 		 (array (setq x 'array) 2)
;; 		 (t (setq x 't) 9))
;; 	       9)
;; 	  (eq x 't)))

(HANDLER-CASE
    (LET ((X #\a))
      (CTYPECASE X
	(STRING (SETQ X 'STRING) 0)
	(CONS (SETQ X 'CONS) 1)
	(ARRAY (SETQ X 'ARRAY) 2)))
  (TYPE-ERROR NIL T)
  (ERROR NIL NIL)
  (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))

(let ((x #*01))
  (and (equal (multiple-value-list (ctypecase x
				     (string (setq x 'string) (values 'string 0))
				     (cons (setq x 'cons) (values 'cons 1))
				     (array (setq x 'array) (values 'array 2))))
	      '(array 2))
       (eq x 'array)))


(let ((x 'a))
  (equal (etypecase x
	   (cons "cons")
	   (symbol "symbol")
	   (number "number"))
	 "symbol"))

(let ((x (list 'a)))
  (equal (etypecase x
	   (cons "cons")
	   (symbol "symbol")
	   (number "number"))
	 "cons"))

(let ((x 0))
  (equal (etypecase x
	   (cons "cons")
	   (symbol "symbol")
	   (number "number"))
	 "number"))

(HANDLER-CASE
    (PROGN
      (LET ((X (MAKE-ARRAY '(3 3))))
	(ETYPECASE X (CONS "cons") (SYMBOL "symbol") (NUMBER "number"))))
  (TYPE-ERROR NIL T)
  (ERROR NIL NIL)
  (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))


(HANDLER-CASE
    (PROGN
      (LET ((A NIL))
	(ETYPECASE A)))
  (TYPE-ERROR NIL T)
  (ERROR NIL NIL)
  (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))

;; (let ((x ""))
;;   (equal (etypecase x
;; 		       (t "anything"))
;; 	    "anything"))

(let ((x ""))
  (and (eql (etypecase x
	      (string (setq x 'string) 0)
	      (cons (setq x 'cons) 1)
	      (array (setq x 'array) 2))
	    0)
       (eq x 'string)))

(let ((x (list nil)))
  (and (eql (etypecase x
	      (string (setq x 'string) 0)
	      (cons (setq x 'cons) 1)
	      (array (setq x 'array) 2))
	    1)
       (eq x 'cons)))


(let ((x #*01))
  (and (eql (etypecase x
	      (string (setq x 'string) 0)
	      (cons (setq x 'cons) 1)
	      (array (setq x 'array) 2))
	    2)
       (eq x 'array)))

;; (let ((x #\a))
;;   (and (eql (etypecase x
;; 		 (string (setq x 'string) 0)
;; 		 (cons (setq x 'cons) 1)
;; 		 (array (setq x 'array) 2)
;; 		 (t (setq x 't) 9))
;; 	       9)
;; 	  (eq x 't)))

(HANDLER-CASE
    (PROGN
      (LET ((X #\a))
	(ETYPECASE X
	  (STRING (SETQ X 'STRING) 0)
	  (CONS (SETQ X 'CONS) 1)
	  (ARRAY (SETQ X 'ARRAY) 2))))
  (TYPE-ERROR NIL T)
  (ERROR NIL NIL)
  (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))

(let ((x #*01))
  (and (equal (multiple-value-list (etypecase x
				     (string (setq x 'string) (values 'string 0))
				     (cons (setq x 'cons) (values 'cons 1))
				     (array (setq x 'array) (values 'array 2))))
	      '(array 2))
       (eq x 'array)))


(macro-function 'multiple-value-bind)
(equal (multiple-value-bind (f r) 
	   (floor 130 11)
	 (list f r))
       '(11 9))

(multiple-value-bind (a b c d)
    (values 0 1 2 3 4 5)
  (and (eql a 0)
       (eql b 1)
       (eql c 2)
       (eql d 3)))

(multiple-value-bind (a b c d)
    (values 0 1)
  (and (eql a 0)
       (eql b 1)
       (eql c nil)
       (eql d nil)))

(equal (multiple-value-list (multiple-value-bind (a b)
				(values 0 1)
			      (values a b 2 3)))
       '(0 1 2 3))

(multiple-value-bind ()
    (values 0 1 2)
  t)

(null (multiple-value-bind () nil))

(eql (multiple-value-bind (a)
	 (floor 130 11)
       (+ a 10))
     21)

(eql (multiple-value-bind (a)
	 (floor 130 11)
       (+ a 10)
       (incf a 100)
       (+ a 10))
     121)



(equal (multiple-value-call #'list 1 '/ (values 2 3) '/ (values) '/ (floor 2.5))
       '(1 / 2 3 / / 2 0.5))
(eql (+ (floor 5 3) (floor 19 4)) (+ 1 4))
(eql (multiple-value-call #'+ (floor 5 3) (floor 19 4)) (+ 1 2 4 3))

(let ((list nil))
  (and (eql (multiple-value-call (progn (push 'function list) #'+)
				 (progn (push 0 list) 0)
				 (progn (push 1 list) (values 1 2))
				 (progn (push 2 list) (values 3 4 5))
				 (progn (push 3 list) (values 6 7 8 9)))
	    45)
       (equal (reverse list) '(function 0 1 2 3))))

(eql (multiple-value-call #'+ 0 1 2 3 4) 10)
(eql (multiple-value-call #'+) 0)
(equal (multiple-value-list
	(multiple-value-call #'values
			     0 1 (values 2) (values 3 4) (values 5 6 7)))
       '(0 1 2 3 4 5 6 7))
(special-operator-p 'multiple-value-call)



(macro-function 'multiple-value-list)
(equal (multiple-value-list (floor -3 4)) '(-1 1))
(equal (multiple-value-list
	(progn
	  (values 'a 'b)
	  0))
       '(0))
(equal (multiple-value-list
	(prog1
	  (values 'a 'b)
	  0))
       '(a))

(equal (multiple-value-list
	(multiple-value-prog1
	  (values 'a 'b)
	  0))
       '(a b))

(special-operator-p 'multiple-value-prog1)
(eql (multiple-value-prog1 1 2 3) 1)
(eql (multiple-value-prog1 1 2 3) 1)


(let ((temp '(1 2 3)))
  (multiple-value-bind (a b c)
      (multiple-value-prog1
       (values-list temp)
       (setq temp nil)
       (values-list temp))
    (and (eql a 1)
	 (eql b 2)
	 (eql c 3))))


(zerop (multiple-value-prog1 0
			     (values 0 1)
			     (values 0 1 2)))

(equal (multiple-value-list (multiple-value-prog1 (progn 0
							 (values 0 1)
							 (values 0 1 2))))
       '(0 1 2))


(let (quotient remainder)
  (and (eql (multiple-value-setq (quotient remainder) (truncate 3.2 2)) 1)
       (eql quotient 1)
       (eql remainder 1.2)))
(let ((a 7)
      (b 8)
      (c 9))
  (and (eql (multiple-value-setq (a b c) (values 1 2)) 1)
       (eql a 1)
       (eql b 2)
       (eql c NIL)))

(let ((a 0)
      (b 1))
  (and (eql (multiple-value-setq (a b) (values 4 5 6)) 4)
       (eql a 4)
       (eql b 5)))


(null (multiple-value-list (values-list nil)))
(equal (multiple-value-list (values-list '(1))) '(1))
(equal (multiple-value-list (values-list '(1 2))) '(1 2))
(equal (multiple-value-list (values-list '(1 2 3))) '(1 2 3))

(every #'(lambda (list) (equal (multiple-value-list (values-list list)) list))
       '()
       '(a)
       '(a b)
       '(a b c)
       '(a b c d)
       '(a b c d e)
       '(a b c d e f)
       '(a b c d e f g)
       '(a b c d e f g h))


(macro-function 'nth-value)
(eql (nth-value 0 (values 'a 'b)) 'A)
(eql (nth-value 1 (values 'a 'b)) 'B)
(null (nth-value 2 (values 'a 'b)))
(multiple-value-bind (a b eq?)
    (let* ((x 83927472397238947423879243432432432)
	   (y 32423489732)
	   (a (nth-value 1 (floor x y)))
	   (b (mod x y)))
      (values a b (= a b)))
  (and (eql a 3332987528)
       (eql b 3332987528)
       eq?))

(null (nth-value 0 (values)))
(eql (nth-value 0 1) 1)
(null (nth-value 1 1))
(eql (nth-value 0 (values 0 1 2)) 0)
(eql (nth-value 1 (values 0 1 2)) 1)
(eql (nth-value 2 (values 0 1 2)) 2)
(eql (nth-value 3 (values 0 1 2)) nil)
(eql (nth-value 4 (values 0 1 2)) nil)
(eql (nth-value 5 (values 0 1 2)) nil)


(let ((z (list 0 1 2 3)))
  (eql (prog* ((y z)
	      (x (car y)))
	     (return x))
       (car z)))


(macro-function 'prog)
(macro-function 'prog*)
(let ((a 1))
  (eq (prog ((a 2) (b a)) (return (if (= a b) '= '/=))) '/=))

(eq (prog* ((a 2) (b a)) (return (if (= a b) '= '/=))) '=)
(null (prog () 'no-return-value))

(flet ((king-of-confusion (w)
        "Take a cons of two lists and make a list of conses.
Think of this function as being like a zipper."
	(prog (x y z)			;Initialize x, y, z to NIL
	      (setq y (car w) z (cdr w))
	 loop
	      (cond ((null y) (return x))
		    ((null z) (go err)))
	 rejoin
	      (setq x (cons (cons (car y) (car z)) x))
	      (setq y (cdr y) z (cdr z))
	      (go loop)
	 err
	      (cerror "Will self-pair extraneous items"
		      "Mismatch - gleep!  ~S" y)
	      (setq z y)
	      (go rejoin))))
  (and (equal (king-of-confusion '((0 1 2) . (a b c)))
	      '((2 . C) (1 . B) (0 . A)))
       (equal (king-of-confusion '((0 1 2 3 4 5) . (a b c d e f)))
	      '((5 . F) (4 . E) (3 . D) (2 . C) (1 . B) (0 . A)))))


(null (prog () t))
(null (prog ()))
(eql (let ((a 0)
	   (b 0))
       (prog ((a 10)
	      (b 100))
	     (return (+ a b))))
     110)

(prog (a
       (b 1)
       (c 2))
      (return (and (null a) (eql b 1) (eql c 2))))

(prog ((a 0)
       b
       (c 2))
      (return (and (eql a 0) (null b) (eql c 2))))

(prog ((a 0)
       (b 1)
       c)
      (return (and (eql a 0) (eql b 1) (null c))))

(prog (a b c)
      (return (every #'null (list a b c))))

(eql (let ((a 0))
       (declare (special a))
       (flet ((ref-a () a))
	 (prog ((a 10))
	       (declare (special a))
	       (return (ref-a)))))
     10)

(let ((a 0))
  (declare (special a))
  (and (eql (flet ((ref-a () a))
	      (prog ((a 10)
		     b
		     (c 100))
		    (declare (special a))
		    (setq b 1)
		    (return (+ (ref-a) b c))))
	    111)
       (eql a 0)))

(let ((a 0))
  (declare (special a))
  (and (equal (multiple-value-list (flet ((ref-a () a))
				     (prog ((a 10)
					    b
					    (c 100))
					   (declare (special a))
					   (setq b 1)
					   (return (values (ref-a) b c)))))
	      '(10 1 100))
       (eql a 0)))

(let ((a 0))
  (and (eql (prog () (return a)) 0)
       (eql a 0)))


(flet ((rev (list)
	 (prog ((x list)
		(result nil))
	   top
	    (when (null x)
	      (return result))
	    (psetq x (cdr x)
		   result (cons (car x) result))
	    (go top))))
  (and (equal (rev '(0 1 2 3))
	      '(3 2 1 0))
       (equal (rev nil)
	      nil)
       (equal (rev '(0))
	      '(0))))

(eql (prog (val)
	   (setq val 1)
	   (go point-a)
	   (incf val 16)
      point-c
	   (incf val 04)
	   (go point-b)
	   (incf val 32)
      point-a
	   (incf val 02)
	   (go point-c)
	   (incf val 64)
      point-b
	   (incf val 08)
	   (return val))
     15)

(let ((a 0))
  (and (equal (multiple-value-list (prog ((a 100)
					  (b a)
					  (c 1))
					 (return (values a b c))))
	      '(100 0 1))
       (eql a 0)))


(null (prog* () 'no-return-value))
(flet ((king-of-confusion (w)
        "Take a cons of two lists and make a list of conses.
Think of this function as being like a zipper."
	(prog* (x y z)			;Initialize x, y, z to NIL
	      (setq y (car w) z (cdr w))
	 loop
	      (cond ((null y) (return x))
		    ((null z) (go err)))
	 rejoin
	      (setq x (cons (cons (car y) (car z)) x))
	      (setq y (cdr y) z (cdr z))
	      (go loop)
	 err
	      (cerror "Will self-pair extraneous items"
		      "Mismatch - gleep!  ~S" y)
	      (setq z y)
	      (go rejoin))))
  (and (equal (king-of-confusion '((0 1 2) . (a b c)))
	      '((2 . C) (1 . B) (0 . A)))
       (equal (king-of-confusion '((0 1 2 3 4 5) . (a b c d e f)))
	      '((5 . F) (4 . E) (3 . D) (2 . C) (1 . B) (0 . A)))))

(null (prog* () t))
(null (prog* ()))
(eql (let ((a 0)
	   (b 0))
       (prog* ((a 10)
	      (b 100))
	     (return (+ a b))))
     110)

(prog* (a
       (b 1)
       (c 2))
      (return (and (null a) (eql b 1) (eql c 2))))

(prog* ((a 0)
       b
       (c 2))
      (return (and (eql a 0) (null b) (eql c 2))))

(prog* ((a 0)
       (b 1)
       c)
      (return (and (eql a 0) (eql b 1) (null c))))

(prog* (a b c)
      (return (every #'null (list a b c))))

(eql (let ((a 0))
       (declare (special a))
       (flet ((ref-a () a))
	 (prog* ((a 10))
	       (declare (special a))
	       (return (ref-a)))))
     10)

(let ((a 0))
  (declare (special a))
  (and (eql (flet ((ref-a () a))
	      (prog* ((a 10)
		     b
		     (c 100))
		    (declare (special a))
		    (setq b 1)
		    (return (+ (ref-a) b c))))
	    111)
       (eql a 0)))

(let ((a 0))
  (declare (special a))
  (and (equal (multiple-value-list (flet ((ref-a () a))
				     (prog* ((a 10)
					    b
					    (c 100))
					   (declare (special a))
					   (setq b 1)
					   (return (values (ref-a) b c)))))
	      '(10 1 100))
       (eql a 0)))

(let ((a 0))
  (and (eql (prog* () (return a)) 0)
       (eql a 0)))


(flet ((rev (list)
	 (prog* ((x list)
		(result nil))
	   top
	    (when (null x)
	      (return result))
	    (psetq x (cdr x)
		   result (cons (car x) result))
	    (go top))))
  (and (equal (rev '(0 1 2 3))
	      '(3 2 1 0))
       (equal (rev nil)
	      nil)
       (equal (rev '(0))
	      '(0))))

(eql (prog* (val)
	   (setq val 1)
	   (go point-a)
	   (incf val 16)
      point-c
	   (incf val 04)
	   (go point-b)
	   (incf val 32)
      point-a
	   (incf val 02)
	   (go point-c)
	   (incf val 64)
      point-b
	   (incf val 08)
	   (return val))
     15)

(let ((a 0))
  (and (equal (multiple-value-list (prog* ((a 100)
					   (b a)
					   (c 1))
					  (return (values a b c))))
	      '(100 100 1))
       (eql a 0)))



(macro-function 'prog1)
(macro-function 'prog2)

(eql (let ((temp 1))
       (prog1 temp (incf temp) temp))
     1)
(let ((temp t))
  (and (eq (prog1 temp (setq temp nil)) 't)
       (null temp)))

(equal (multiple-value-list (prog1 (values 1 2 3) 4)) '(1))

(let ((temp (list 'a 'b 'c)))
  (and (eq (prog1 (car temp) (setf (car temp) 'alpha)) 'a)
       (equal temp '(ALPHA B C))))

(equal (flet ((swap-symbol-values (x y)
	        (setf (symbol-value x) 
		      (prog1 (symbol-value y)
			(setf (symbol-value y) (symbol-value x))))))
	 (let ((*foo* 1) (*bar* 2))
	   (declare (special *foo* *bar*))
	   (swap-symbol-values '*foo* '*bar*)
	   (list *foo* *bar*)))
       '(2 1))

(let ((temp 1))
  (and (eql (prog2 (incf temp) (incf temp) (incf temp)) 3)
       (eql temp 4)))

(equal (multiple-value-list (prog2 1 (values 2 3 4) 5)) '(2))
(equal (multiple-value-list (prog2 1 (values 2 3 4) 5 (values 6 7))) '(2))

(eql (prog1 1) 1)
(eql (prog1 1 2) 1)
(eql (prog1 1 2 3) 1)

(equal (multiple-value-list (prog1 (values 1 2 3))) '(1))

(equal (multiple-value-list (prog1
				(values 1 2 3)
			      (values 4 5 6)
			      (values 7 8 9)))
       '(1))

(eql (prog2 1 2) 2)
(eql (prog2 1 2 3) 2)
(eql (prog2 1 2 3 4) 2)

(let ((x 0))
  (and (eql (prog2 (incf x)
		(incf x)
	      (incf x)
	      (incf x))
	    2)
       (eql x 4)))



(let ((x (cons 'a 'b))
      (y (list 1 2 3)))
  (and (equal (setf (car x) 'x (cadr y) (car x) (cdr x) y) '(1 X 3))
       (equal x '(X 1 X 3))
       (equal y '(1 X 3))))

(let ((x (cons 'a 'b))
      (y (list 1 2 3)))
  (and (null (psetf (car x) 'x (cadr y) (car x) (cdr x) y))
       (equal x '(X 1 A 3))
       (equal y '(1 A 3))))

(null (setf))
(null (psetf))

(let ((a 0))
  (and (eql (setf a 10) 10)
       (eql a 10)))

(let ((a 0)
      (b 1))
  (and (eql (setf a 10 b 20) 20)
       (eql a 10)
       (eql b 20)))

(let ((a 0)
      (b 1)
      (c 2))
  (and (eql (setf a 10 b (+ a 10) c (+ b 10)) 30)
       (eql a 10)
       (eql b 20)
       (eql c 30)))

(let ((x (list 0 1 2)))
  (and (eq (setf (car x) 'a) 'a)
       (eq (setf (cadr x) 'b) 'b)
       (eq (setf (caddr x) 'c) 'c)
       (equal x '(a b c))))


(let ((a 0))
  (and (null (psetf a 10))
       (eql a 10)))

(let ((a 0)
      (b 1))
  (and (null (psetf a 10 b 20))
       (eql a 10)
       (eql b 20)))

(let ((a 0)
      (b 1)
      (c 2))
  (and (null (psetf a 10 b (+ a 10) c (+ b 10)))
       (eql a 10)
       (eql b 10)
       (eql c 11)))

(let ((x (list 0 1 2)))
  (and (null (psetf (car x) 'a))
       (null (psetf (cadr x) 'b))
       (null (psetf (caddr x) 'c))
       (equal x '(a b c))))


(let ((x (make-array '(2 3) :initial-contents '((a b c) (x y z)))))
  (and (eql (setf (aref x 0 0) 0.0) 0.0)
       (eql (setf (aref x 0 1) 0.1) 0.1)
       (eql (setf (aref x 0 2) 0.2) 0.2)
       (eql (setf (aref x 1 0) 1.0) 1.0)
       (eql (setf (aref x 1 1) 1.1) 1.1)
       (eql (setf (aref x 1 2) 1.2) 1.2)
       (equalp x #2A((0.0 0.1 0.2) (1.0 1.1 1.2)))))

(let ((x (make-array 4 :element-type 'bit :initial-element 0)))
  (and (equalp x #*0000)
       (eql (setf (bit x 0) 1) 1)
       (eql (setf (bit x 2) 1) 1)
       (equal x #*1010)))

(let ((x (copy-seq "dog")))
  (and (eql (setf (char x 0) #\c) #\c)
       (eql (setf (char x 1) #\a) #\a)
       (eql (setf (char x 2) #\t) #\t)
       (equal x "cat")))

(let ((x (copy-seq "dog")))
  (and (eql (setf (schar x 0) #\c) #\c)
       (eql (setf (schar x 1) #\a) #\a)
       (eql (setf (schar x 2) #\t) #\t)
       (equal x "cat")))

(let ((x (copy-seq "dog")))
  (and (eql (setf (elt x 0) #\c) #\c)
       (eql (setf (elt x 1) #\a) #\a)
       (eql (setf (elt x 2) #\t) #\t)
       (equal x "cat")))

(let ((x (list 0 1 2)))
  (and (eql (setf (elt x 0) #\c) #\c)
       (eql (setf (elt x 1) #\a) #\a)
       (eql (setf (elt x 2) #\t) #\t)
       (equal x '(#\c #\a #\t))))

(let ((x #'(lambda (a) (+ a 10)))
      (saved (when (fboundp 'test-fn) (fdefinition 'test-fn))))
  (unwind-protect (and (eq (setf (fdefinition 'test-fn) x) x)
		       (eql (test-fn 10) 20))
    (when saved
      (setf (fdefinition 'test-fn) saved))))

(let ((table (make-hash-table)))
  (and (equal (multiple-value-list (gethash 1 table)) '(NIL NIL))
       (equal (multiple-value-list (gethash 1 table 2)) '(2 NIL))
       (equal (setf (gethash 1 table) "one") "one")
       (equal (setf (gethash 2 table "two") "two") "two")
       (multiple-value-bind (value present-p) (gethash 1 table)
	 (and (equal value "one")
	      present-p))
       (multiple-value-bind (value present-p) (gethash 2 table)
	 (and (equal value "two")
	      present-p))))

(let ((table (make-hash-table)))
  (and (equal (multiple-value-list (gethash nil table)) '(NIL NIL))
       (null (setf (gethash nil table) nil))
       (multiple-value-bind (value present-p) (gethash nil table)
	 (and (equal value NIL)
	      present-p))))

(let ((x (copy-seq #*0101)))
  (and (eql (setf (sbit x 0) 1) 1)
       (eql (setf (sbit x 2) 1) 1)
       (equal x #*1111)))


(let ((a 0)
      (b 1))
  (and (equal (multiple-value-list (setf (values a b) (values 'x 'y 'z)))
	      '(x y))
       (eq a 'x)
       (eq b 'y)))

(let ((x (list 0 1 2))
      (order nil))
  (and
   (equal (multiple-value-list (setf (values (car   (prog1 x (push 0 order)))
					     (cadr  (prog1 x (push 1 order)))
					     (caddr (prog1 x (push 2 order))))
				     (values 'a 'b)))
	  '(a b nil))
   (equal x '(a b nil))
   (equal order '(2 1 0))))


(let ((a 'a)
      (b 'b)
      (c 'c))
  (and (equal (multiple-value-list (setf (values (values a) (values b c))
					 (values 0 1 2 3 4)))
	      '(0 1))
       (eql a 0)
       (eql b 1)
       (null c)))

(let ((a 'a)
      (b 'b)
      (c 'c)
      (d 'd))
  (and (equal (multiple-value-list (setf (values (values a b) (values c d))
					 (values 0 1 2 3 4)))
	      '(0 1))
       (eql a 0)
       (null b)
       (eql c 1)
       (null d)))

(let ((a 'a)
      (b 'b)
      (c 'c)
      (d 'd))
  (and (equal (multiple-value-list (setf (values (values a b) (values c d))
					 (values 0)))
	      '(0 nil))
       (eql a 0)
       (null b)
       (null c)
       (null d)))

(let ((a 'a)
      (b 'b)
      (c 'c))
  (and (equal (multiple-value-list (setf (values a) (values 0 1 2)))
	      '(0))
       (eql a 0)
       (eq b 'b)
       (eq c 'c)))


(let ((x (list 1 2 3))
      (y 'trash))
  (and (eq (shiftf y x (cdr x) '(hi there)) 'TRASH)
       (equal x '(2 3))
       (equal y '(1 HI THERE))))

(let ((x (list 'a 'b 'c)))
  (and (eq (shiftf (cadr x) 'z) 'B)
       (equal x '(A Z C))
       (eq (shiftf (cadr x) (cddr x) 'q) 'Z)
       (equal x '(A (C) . Q))))

(let ((n 0)
      (x (list 'a 'b 'c 'd)))
  (and (eq (shiftf (nth (setq n (+ n 1)) x) 'z) 'B)
       (equal x '(A Z C D))))


(let ((a 0)
      (b 1)
      (c 2)
      (d 3))
  (and (equal (multiple-value-list (shiftf (values a b) (values c d)
					   (values 4 5)))
	      '(0 1))
       (eql a 2)
       (eql b 3)
       (eql c 4)
       (eql d 5)))



(let ((n 0)
      (x (list 'a 'b 'c 'd 'e 'f 'g)))
  (and (null (rotatef (nth (incf n) x)
		      (nth (incf n) x)
		      (nth (incf n) x)))
       (equal x '(A C D B E F G))))

(let ((x (list 'a 'b 'c)))
  (and (null (rotatef (first x) (second x) (third x)))
       (equal x '(b c a))))

(let ((x (list 'a 'b 'c 'd 'e 'f)))
  (and (null (rotatef (second x) (third x) (fourth x) (fifth x)))
       (equal x '(a c d e b f))))

(null (rotatef))
(let ((a 0))
  (and (null (rotatef a))
       (zerop a)))

(let ((x (list 'a 'b 'c))
      (order nil))
  (and (null (rotatef (first  (progn (push 1 order) x))
		      (second (progn (push 2 order) x))
		      (third  (progn (push 3 order) x))))
       (equal x '(b c a))
       (equal order '(3 2 1))))

(let ((x (list 'a 'b 'c))
      (order nil))
  (and (null (psetf (first  (progn (push 1 order) x))
		    (second (progn (push 2 order) x))
		    
		    (second (progn (push 2 order) x))
		    (third  (progn (push 3 order) x))

		    (third  (progn (push 3 order) x))
		    (first  (progn (push 1 order) x))))
       (equal x '(b c a))
       (equal order '(1 3 3 2 2 1))))

(let ((a 0)
      (b 1)
      (c 2)
      (d 3))
  (and (null (rotatef (values a b) (values c d)))
       (eql a 2)
       (eql b 3)
       (eql c 0)
       (eql d 1)))