;;
;; Created By:    Karin M. Sye
;;
;; Creation Date:  21, Dec., 86
;;
;; Last Update:   >> n MonthName << 86 
;;
;; Filed As:      {eris}<lispcore>cml>test> 8-macro-arg-eval-order.test
;;

(do-test "test order of evaluation of arguments to system provided macros"
	(let (counter macro-name)
		(macrolet
			((foo (counter-value foo-value)
					"define the test parameter production"
					`(progn
						(unless (= ,counter-value (incf counter)) 
							   (print (concatenate 'string "arguments to macro '" 
													macro-name  
													"' evaluated out of order") *error-output*))
						,foo-value))

			 (test (name) 
					"reset the variables COUNTER and MACRONAME"
					`(setq counter 0 macro-name ,name))  )
			;;
			;;  now let's do the tests
			;;
			;;	AND
			;;
			(test "and")
			(and (foo 1 1) (foo 2 (values 6 60 600)) (foo 3 (values nil t)) (foo 99 #\a))
			(and (foo 4 'a) (foo 5 'b) (foo 6 'c) (foo 7 'd))
			;;
			;;	CASE
			;;
			(test "case")
			(case  'bar ( bar1       (foo 99 'bar1))
					  ((bar3 bar ) (foo 1 1) (foo 2 2) (foo 3 3) (foo 4 'finju))
					  ( bar4       (foo 99 'bar4))
					  ( otherwise  (foo 99 'other)))
			;
			(case 'quack ((3 quack3) (foo 99 '3))
					   (('quack)   (foo 99 '0))
					   (t			(foo 5 5) (foo 6 6) (foo 7 7) (foo 8 'quit)))
			;
			(case nil	   ( non-nil    (foo 99 'non-nil))
					   ( nill       (foo 99 'nill)))
			;
			(case t      ( t (foo 9 t)))
			;;
			;;	CCASE
			;;
			(test "ccase")
			(let ( (bar '(bar bar2 t))  )
				(ccase (pop bar) 	( bar1       (foo 99 'bar1))
					  	  		((bar3 bar ) (foo 1 1) (foo 2 2) (foo 3 3) (foo 4 'finju))
					  	  		( bar4       (foo 99 'bar4)))
				;
				(ccase (pop bar)	(bar2 	   (foo 5 5) (foo 6 6) (foo 7 7) (foo 8 'quit)))
				;
				(ccase (pop bar)	((t)		   (foo 9 t))))
			;;
			;;	CHECK-TYPE
			;;
			(test "check-type")
			(let ((var '(12 #\w "str" (1 2 3)) ))
				(check-type (caddr (foo 1 var)) string  (foo 2 (concatenate 'string "a " "string"))  ))
			;;
			;;	COND
			;;
			(test "cond")
			(cond ((foo 1 (oddp 20)) (foo 99 (1+ 20)))
				 ((foo 2 (evenp 3)) (foo 99 (1- 3)))
				 ((foo 3 (= (sqrt #18r10000) #18r100)) (foo 4 'gochu))
				 ((foo 99 t) 180)) 
			;;
			(cond ((foo 5 nil) (foo 99 10))
				 ((foo 6 nil) (foo 99 20))
				 ((foo 7 t) (foo 8 30) (foo 9 40) (foo 10 (values 30 40 50)))
				 ((foo 99 t) "buggy"))
			;;
			;;	CTYPECASE
			;;
			(test "ctypecase")
			(let ((var '(100 #\q t) ))
				(ctypecase  (foo 1 (pop var))
						((or float string) (foo 99 'fool1))
						((integer 105 200) (foo 99 'fool2))
						( fixnum		    (foo 2 2) (foo 3 3) (foo 4 4) (foo 5 'howdy))
						( package		    (foo 99 'fool3)))
				;
				(ctypecase (foo 6 (pop var))
						((or vector stream) 	  (foo 99 'fool4))
						((or string character) (foo 7 7) (foo 8 8) (foo 9 (values 7 8 9)))
						( ratio			  (foo 99 'fool5)))
				;
				(ctypecase (foo 10 (pop var))
						 (atom			  (foo 11 'hwow!))))
			;;
			;;	DECF
			;;
			(test "decf")
			(let ((a 0)) (declare (special a)) (decf (symbol-value (foo 1 'a)) (foo 2 -5))  
					   				    (decf (symbol-value (foo 3 'a)) (foo 4 50)))
			;;
			;;	DEFCONSTANT
			;;
			(test "defconstant")
			(defconstant mac-arg-3 (foo 1 246))
			(defconstant mac-arg-4 (foo 2 135) (foo 3 "a constant"))
			;;
			;;	DEFINE-MODIFY-MACRO name lambda-list function [doc-string]
			;;
			;;   ** Test case was not generated since none of the arguments need to be evaluated **
			;;
			;;	DEFMACRO
			;;
			(test "defmacro")
			(defmacro mac ( x y)
					(foo 1 (declare (integer x y)))
					(foo 2 "a dummy macro")
					(foo 3 'nonsense1)
					(foo 4 'nonsense2)
					(foo 5 `(progn (values (+ ,x ,y) (- ,x ,y) (* ,x ,y)))))
			(fmakunbound 'mac)
			;;
			;;	DEFPARAMETER
			;;
			(test "defparameter")
			(defparameter mac-arg-2 (foo 1 100))
			(defparameter mac-arg-2 (foo 2 300)	(foo 3 "a global var"))	
			;;
			;;	DEFSTRUCT
			;;
			(test "defstruct")
			(let ()
				(defstruct new-blocks
								(length 		  (foo 1 10) 		 :type fixnum)
								(wide    		  (foo 2 5 )		 :type fixnum)
								(height 		  (foo 3 20) 		 :type fixnum)
								(volume 		  (foo 4 (* 5 10 20)) :type fixnum)
								(number-of-block (foo 5 8) 		 :type fixnum  :read-only t)
								(total-volume 	  (foo 6 (* 5 10 20 8)) :type fixnum)  )
				(make-new-blocks))
			;;
			;;	DEFTYPE
			;;
			(test "deftype")
			(deftype square-matrix (&optional type size)
				"SQUARE-MATRIX includes all aquare two-dimentional arrays."
				(foo 1 (setq a1 'array)) 
				(foo 2 (setq a2 `,type)) 
				(foo 3 (setq a3 `(,size ,size)))
				(foo 4 (list a1 a2 a3) ))
					
			;;
			;;	DEFUN
			;;
			(test "defun")
			(defun fun (x y buf)
					(foo 1 (declare (integer x y) (list buf)))
					(foo 2 "a fun function")
					(foo 3 (push 'form1 buf))
					(foo 4 (push 'form2 buf))
					(foo 5 (push 'form3 buf))
					(foo 6 (if (evenp x) (push 'form4 buf)))
					(foo 7 (if (oddp y) (return buf)))
					(foo 8 (return (progn (push 'form8 buf) buf))))
			(fmakunbound 'fun)
	
			;;
			;;	DEFVAR
			;;
			(test "defvar")
			(every #'makunbound '(mac-arg-1 mac-arg-11))
			(defvar mac-arg-1 (foo 3 11)) 
			(defvar mac-arg-11 (foo 2 22) (foo 1 "a special var"))
			(evenp (+ mac-arg-11 mac-arg-1))
			;;
			;;	DO
			;;
			(test "do")
			(do ((z '(1 2 3 4 5) (rest z)))
				((foo 1 (null z))  "something is wrong")
				(foo 2 (and (= (car z) 1) (return 'gochu))))
			;
			(do ((w 0 (+ w 1))  (buf '(9)))
				((foo 3 (zerop w)) (foo 4 (nconc buf (list w (+ 1 w)))) (foo 5 (reverse  buf)))
				(foo 6 "wrong"))
			;
			(do ((m 0 (incf m)) (n 2 (incf n 2)) (o 3 (incf o 3)))
				((foo 6 (< 10 (+ m n o))) "sum > 10")
				(foo 7 (declare (fixnum m)))
				(foo 8 (declare (fixnum n)))
				(foo 9 (declare (integer o)))
				(foo 10 (if (plusp (lcm m n o)) (return "+")))
				(foo 11 (if (minusp (gcd m n o)) (return "-")))
				(foo 12 (return 'hooray)))
			;;
			;;	DO*
			;;
			(test "do*")
			(do* ((z '(1 2 3 4 5) (rest z)))
				((foo 1 (null z))  "something is wrong")
				(foo 2 (and (= (car z) 1) (return 'gochu))))
			;
			(do* ((w 0 (+ w 1))  (buf '(9)))
				((foo 3 (zerop w)) (foo 4 (nconc buf (list w (+ 1 w)))) (foo 5 (reverse  buf)))
				(foo 6 "wrong"))
			;
			(do* ((m 0 (incf m)) (n 2 (incf n 2)) (o 3 (incf o 3)))
				((foo 6 (< 10 (+ m n o))) "sum > 10")
				(foo 7 (declare (fixnum m)))
				(foo 8 (declare (fixnum n)))
				(foo 9 (declare (integer o)))
				(foo 10 (if (plusp (lcm m n o)) (return "+")))
				(foo 11 (if (minusp (gcd m n o)) (return "-")))
				(foo 12 (return 'hooray)))
			;;
			;;	DO-ALL-SYMBOLS
			;;
			(test "do-all-symbols")
			(progn  (do-all-symbols (x)
							    (foo 1 1)
							    (foo 2 2)
							    (foo 3 3)
							    (foo 4 (if (find-symbol (string x) (car (list-all-packages))) (return 'first)))))
			;;
			;;	DO-EXTERNAL-SYMBOLS
			;;
			(test "do-external-symbols")
			(progn  (import '(lisp:vector) 'user)
				   (export '(user::vector) 'user)
				   (do-external-symbols (x (find-package 'user))
								    (foo 1 1)
								    (foo 2 2)
								    (foo 3 3)
								    (foo 4 (if (find-symbol (string x) 'user) (return 99)))))
			;;
			;;	DO-SYMBOLS
			;;
			(test "do-symbols")
			(let ((pac  (or (find-package "macro-arg-pac") (make-package "macro-arg-pac" :use NIL) )) result)
				(progn (set (intern "joke" pac) 789)
					  (do-symbols (x pac (foo 5 result))
							    (foo 1 (push (numberp x) result))
							    (foo 2 (push (arrayp x) result))
							    (foo 3 (push (rationalp x) result))
							    (foo 4 (push (symbolp x) result))   )))
			;;
			;;	DOLIST
			;;
			(test "dolist")
			(dolist (x (foo 1 '()) (foo 2 "bye")) (foo 3 nil))
			;
			(dolist (x (foo 3 '(#\q)) (foo 5 "end-of-list")) (foo 4 (characterp x)))
			;
			(dolist (x (foo 6 '(2)) (foo 99 'jumpy)) (foo 7 (setq x (sqrt x))) (foo 8 (return x)))
			;;
			;;	DOTIME
			;;
			(test "dotimes")
			(dotimes (x (foo 1 0) (foo 2 "bye")) (foo 3 nil))
			;
			(dotimes (x (foo 3 1) (foo 5 "end-of-list")) (foo 4 (characterp x)))
			;
			(dotimes (x (foo 6 1) (foo 99 'jumpy)) 
					(foo 7 (setq x (sqrt x)))
					(foo 8 (go tag))
				done (foo 10 (return x))
				tag	(foo 9 (go done)))
			;;
			;;	ECASE
			;;
			(test "ecase")
			(let ( (bar '(bar bar2 t))  )
				(ecase (pop bar) 	( bar1       (foo 99 'bar1))
					  	  		((bar3 bar ) (foo 1 1) (foo 2 2) (foo 3 3) (foo 4 'finju))
					  	  		( bar4       (foo 99 'bar4)))
				;
				(ecase (pop bar)	(bar2 	   (foo 5 5) (foo 6 6) (foo 7 7) (foo 8 'quit)))
				;
				(ecase (pop bar)	((t)		   (foo 9 t))))
			;;
			;;	ETYPECASE
			;;
			(test "etypecase")
			(etypecase  (foo 1 100)
						((or float string) (foo 99 'fool1))
						((integer 105 200) (foo 99 'fool2))
						( fixnum		    (foo 2 2) (foo 3 3) (foo 4 4) (foo 5 'howdy))
						( package		    (foo 99 'fool3)))
			;
			(etypecase (foo 6 #\q)
						((or vector stream) 	  (foo 99 'fool4))
						((or string character) (foo 7 7) (foo 8 8) (foo 9 (values 7 8 9)))
						( ratio			  (foo 99 'fool5)))

			;;
			;;	INCF
			;;
			(test "incf")
			(let ((a 0)) (declare (special a)) (incf (symbol-value (foo 1 'a)) (foo 2 -5))  
					   				    (incf (symbol-value (foo 3 'a)) (foo 4 50)))
			;;
			;;	LOCALLY
			;;
			(test "locally")
			(locally (foo 1 (floor 3 8)) (foo 2 (ceiling 3 8)) (foo 3 (truncate 3 8)) (foo 4 (round 3 8)))
			;
			(locally (foo 5 (declare (inline floor round car)))
				    (foo 6 (declare (notinline truncate ceiling cdr)))
				    (foo 7 (declare (optimize space)))
				    (foo 8 (floor 3 8)) (foo 9 (ceiling 3 8)) (foo 10 (truncate 3 8)) (foo 11 (round 3 8)))
			;;
			;;	LOOP
			;;
			(test "loop")
			(loop (foo 1 1) (foo 2 2) (foo 3 3) (foo 4 4) (foo 5 5)
				 (foo 6 6) (foo 7 7) (foo 8 8) (foo 9 9) (foo 10 10) (foo 11 (return t)))
			;;
			;;	MULTIPLE-VALUE-BIND
			;;
			(test "multiple-value-bind")
			(multiple-value-bind (n0 n1 n2) (foo 1 (values-list '(0 1 2))) 
									 (foo 2 (setq n1 (+ n0 n2 100)))
									 (foo 3 (setq n2 (* n1 23)))
									 (foo 4 (setq n0 (lcm n1 n2)))
									 (foo 5 (list n0 n1 n2)) )
			;;
			;;	MULTIPLE-VALUE-LIST
			;;
			(test "multiple-value-list")
			(multiple-value-list  (foo 1 (values 'a 'b 'c 'd 'e 'f 'g)))
			(multiple-value-list  (foo 2 '(1 2 3 4 5 6 7)))
			;;
			;;	MULTIPLE-VALUE-SETQ
			;;
			(test "multiple-value-setq")
			(multiple-value-setq (n0 n1 n2) (foo 1 (values 10 20 30 40 50)))
			(multiple-value-setq (n0 n1) (foo 2 (values-list '(11 22))))
			;;
			;;	OR
			;;
			(test "or")
			(or (foo 1 (values nil 1 11)) (foo 2 'nil) (foo 3 3) (foo 4 'atom4) (foo 5 55))
			(or (or (foo 4 nil) (foo 5 'nil)) (or (foo 6 nil) (foo 7 99)) (foo 8 nil) (foo 9 t))
			;;
			;;	POP
			;;
			(test "pop")
			(let ((a '(10 20 30 40 50 (60 77 88))  )) (declare (special a))
				(pop (symbol-value (foo 1 'a)))
				(pop (fifth (foo 2 a))) )
			;;
			;;	PROG
			;;
			(test "prog")
			(prog ((a 1) (b 2) (c 3) (d 4))
				 (foo 1 (setq c (* (+ a d) (- c b))))
				 (foo 2 (setq d (gcd (expt c 3) (* 99 d))))
				 (foo 3 (setq a (lcm c d)))
				 (foo 4 (setq b (complex c a)))
				 (foo 5 (return (list a b c d))) ) 
			;;
			;;	PROG*
			;;
			(test "prog*")
			(prog* ((a 10) (b (* a 2)) (c (+ a b)))
				  (foo 1 (declare (fixnum a b c)))
				  (foo 2 "a simple prog* form")
				  (foo 3 (if (evenp (+ a b)) (go tag1)))
			  tag2 (foo 5 (go exit))
			  tag1 (foo 4 (go tag2))
			  exit (foo 6 (return (mapcar #'list (list a b c)))))
			;;
			;;	PROG1
			;;
			(test "prog1")
			(prog1 (foo 1 "1") (foo 2 "2") (foo 3 "3") (foo 4 "4") (foo 5 "5"))
			(prog1 (foo 6 "66") (foo 7 "77") (foo 8 "done"))
			;;
			;;	PROG2
			;;
			(test "prog2")
			(prog2 (foo 1 'a) (foo 2 (prog2 (foo 3 'c) (foo 4 'd) (foo 5 'e)(foo 6 'f) ))
				  (foo 7 'g))
			(prog2 (foo 8 (defun fun () 'fun-fun)) (foo 9 (fun)) (foo 10 (fmakunbound 'fun)))
			;;
			;;	PSETF
			;;
			(test "psetf")
			(let ((a 22) (b '(1 2 3 4 5)) (c '(11 22 33 44)) (d 44)) (declare (special a d))
				(psetf (symbol-value (foo 1 'a)) (foo 2 b) (second (foo 3 b)) (foo 4 a) (rest (foo 5 c)) (foo 6 d)
					  (symbol-value (foo 7 'd)) (foo 8 (incf a d)) )) 
			;;
			;;	PSETQ
			;;
			(test "psetq")
			(let (a b c d)
				(psetq a (foo 1 'a) b (foo 2 `b) c (foo 3 'c) d (foo 4 'd))
				(psetq a (foo 5 b) b (foo 6 a)))
			;;
			;;	PUSH
			;;
			(test "push")
			(let ((a '(1 2 3 4 5 6 7 8 9 10) ))
				(push (foo 1 100) (third (foo 2 a)))
				(push (foo 3 200) (rest  (foo 4 a)))  )
			;;
			;;	PUSHNEW
			;;
			(test "pushnew")
			(let ( (a 0) (aa '( 5 4 3)) )
				(pushnew (foo 1 (incf a)) (first (foo 2 (list (list a) a))))
				(pushnew (foo 3 (first aa)) (second (foo 4 (setq aa (reverse aa)))) :test (foo 5 #'=) )  )
			;;
			;;	REMF
			;;
			(test "remf")
			(let ((a 1))
				(setf (symbol-plist 'a) '(color blue height 6.6 near-to bar weight  230))
				(remf (symbol-plist (foo 1 'a)) (foo 2 'height))
				(remf (symbol-plist (foo 3 'a)) (foo 4 'weight)) )
			;;
			;;	RETURN
			;;
			(test "return")
			(do () () (return (foo 1 100)))
			(prog () (return (foo 2 30)))
			(dolist (x '(1)) (return (foo 3 x)))
			(dotimes (x 1) (return (foo 4 x))) 
			;;
			;;	ROTATEF
			;;
			(test "rotatef")
			(let ((a '(a b c d e f g h) ))
				(rotatef (car (foo 1 a)) (cadr (foo 2 a)) (caddr (foo 3 a)) (cadddr (foo 4 a)) (fifth (foo 5 a))
					   (sixth (foo 6 a)) (seventh (foo 7 a)) (eighth (foo 8 a))) )
			;;
			;;	SETF 
			;;
			(test "setf")
			(let ((a '(1 2 3 4 5 6 7 8 9 10)) )
				(setf (subseq (foo 1 a) 1 3)  (foo 2 '(11 22)) (cadddr (foo 3 a)) (foo 4 44) 
					 (ninth (foo 5 a)) (foo 6 99)))
			;;
			;;	SHIFTF
			;;
			(test "shiftf")
			(let ((a '(a b c d e f) ))
				(shiftf (car (foo 1 a)) (cadr (foo 2 a)) (caddr (foo 3 a)) (cadddr (foo 4 a)) (fifth (foo 5 a))
					   (sixth (foo 6 a)) (foo 7 'z)) )
			;;
			;;	STEP	form
			;;
			;;	** single form doesn't need test cases **
			;;
			;;	TIME form
			;;
			;;	** single form doesn't need test cases **
			;;
			;;	TRACE {function-name}*
			;; 
			;;	** no arguments need to be evaluated **
			;;	
			;;	UNTRACE {function-name}*
			;;
			;;	** no arguments need to be evaluated **
			;;
			;;	TYPECASE
			;;
			(test "typecase")
			(typecase  (foo 1 100)
						((or float string) (foo 99 'fool1))
						((integer 105 200) (foo 99 'fool2))
						( fixnum		    (foo 2 2) (foo 3 3) (foo 4 4) (foo 5 'howdy))
						( otherwise	    (foo 99 'fool3)))
			;
			(typecase (foo 6 #\q)
						((or vector stream) 	(foo 99 'fool4))
						(otherwise			(foo 7 7) (foo 8 8) (foo 9 (values 7 8 9)))
						(t				(foo 99 'fool5)))
			;;
			;;	UNLESS
			;;
			(test "unless")
			(unless (foo 1 nil) (foo 2 3) (foo 3 4) (foo 4 5) (foo 5 (values 6 66 666)))
			(unless (foo 6 t) (foo 99 "ouch"))
			;;
			;;	WHEN
			;;
			(test "when")
			(when (foo 1 nil) (foo 2 "ouch"))
			(when (foo 2 'star) (foo 3 3) (foo 4 4) (foo 5 5) (foo 6 (values 6 66 666)))
			;;
			;;	WITH-INPUT-FROM-STRING
			;;
			(test "with-input-from-string")
			(let (a str buf)
				(with-input-from-string (s1 (foo 1 "abc")) (foo 2 (read s1)))
				(with-input-from-string (s1 (foo 3 "abcde") :index (symbol-value (foo 11 'a)) :start (foo 4 1) :end (foo 5 4))
								    (foo 6 (setq str (string (read s1))))
								    (foo 7 (push (map 'string #'char-upcase str) buf)) 
								    (foo 8 (push (map 'list #'char-code str) buf))
								    (foo 9 (push (map 'vector #'standard-char-p str) buf))
								    (foo 10 buf)))
			;;
			;;	WITH-OPEN-FILE
			;;
			;;	(more coming)
			;;
			;;	WITH-OPEN-STREAM
			;;
			(test "with-open-stream")
			(let (buf)
				(with-open-stream (strim (foo 1 (make-string-input-stream "abcdefg")))
									(foo 2 (setq buf (string (read strim))))
									(foo 3 (setq buf (concatenate 'string buf " has length of " (prin1-to-string (length buf)))))
									(foo 4 buf)))				
			;;
			;;	WITH-OUTPUT-TO-STRING
			;;
			(test "with-output-to-string")
			(let ((str (make-array 10 :element-type 'character :fill-pointer 0)) buf)
				(with-output-to-string (s1 str)
								  (foo 1 (write-char #\a s1))
								  (foo 2 (write-char #\b s1)) 
								  (foo 3 (push str buf))
								  (foo 4 (write-char #\c s1))
								  (foo 5 (write-char #\d s1))
								  (foo 6 (push str buf))
								  (foo 7 buf)))
		) ; end of macrolet
	) ; end of let
); end of do-test
STOP