;; ********************************************************
;; Test functions to test the working of the debugger
;; ********************************************************

;; Test and
;; (test001 1)
;; (test001 0)

(defun test001 (n)
  (and)
  (and (+ n n))
  (and (+ n n) (* n n))
  (and 1 n (if (zerop n) nil t) (* n n)))

;; Test assert
;; (test002 '(a b c))
;; (test002 '(nil b c))
;; (test003 '(nil b c))
;; (test004 '(nil b c))
;; (test005 '(nil b c))

(defun test002 (n)
  (assert (not (null (first n))))
  n)

(defun test003 (n)
  (assert (not (null (first n))) ((first n)))
  n)

(defun test004 (n)
  (assert (not (null (first n))) ((first n)) "This is a string")
  n)

(defun test005 (n)
  (assert (not (null (first n))) ((first n)) "This is the value ~A" (first n))
  n)

;; block
;; (test006 0)
;; (test006 30)

(defun test006 (n)
  (block beg
    (princ n)
    (setf n (1+ n))
    (if (> n 4)
	(return-from beg n)
      300)))


;; case
;; test007
;; (test007 0)
;; (test007 (/ 1 2))
;; (test007 2)

(defun test007 (n)
  (case (+ n n))
  (case (+ n n)
    (1 (list 'een))
    ((2 3 4) (list 'twee 'drie 'vier))
    (t (list 'other))))


;; catch
;; (test008 0)
;; (test008 1)

(defun test008 (n)
  (catch 'proef
    (princ n)
    (if (zerop n)
	(throw 'proef 100))
    (* n 200)))

;; ccase
;; (test009 '(0))
;; (test009 '(1))

(defun test009 (n)
  (ccase (first n)
	 (1 (list n n))
	 (2 (list n n n))))

;; cond
;; (test010 0)
;; (test010 1)
;; (test010 2)

(defun test010 (n)
  (cond)
  (cond ((= n 0) (list 'zero))
	((= n 1) (list 'one))
	(t (list 'nothing))))


;; decf
;; (test011 '(3))

(defun test011 (n)
  (decf (first n)  20)
  n)

;; defclass
;; (make-instance 'test012)
;; (make-instance 'test013)

(defclass test012 ()
  ((x :initform (cos 0))
   (y :initform (sin 0))))


(defclass test013 ()
     ((x :initform (cos 20) :initarg nx)
      (y :initform (cos 30) :initarg ny))
     (:default-initargs nx (+ 1 2) ny (+ 2 3)))

;; defgeneric
;; (test014 1)
;; (test014 0.5)
;; (test014 "one")
	
(defgeneric test014 (n)
  (:method ((n integer)) (declare (fixnum n)) "test methode" (if (< n 2) 1 (* n (1- n))))
  (:method ((n real)) "testje" (if (< n 2) 1 (* n (1- n))))
  (:method ((n string))  (concatenate 'string n "!"))
  (:documentation "Computes the factorial"))

;;defmethod
;; (test015 10)

(defgeneric test015 (x))
(defmethod test015 ((x number))
  (format t "number primary method called")
  (when (next-method-p) (call-next-method))
  (format t "number primary method finished"))
(defmethod test015 ((n integer))
  (format t "Integer primary method called")
  (when (next-method-p) (call-next-method))
  (format t "Integer primary method finished"))
(defmethod test015 ((n rational))
  (format t "Rational primary method called")
  (when (next-method-p) (call-next-method))
  (format t "Rational  primary method finished"))
(defmethod test015 :before ((x integer))
  (format t "Before integer method called")
  (when (next-method-p) (call-next-method)))

;; defun
;; (test016 1 2 3)
;; (test017 1)
;; (test017 1 2)
;; (test017 1 2 3)
;; (test018 1 2 3)
;; (test019 10 :k1 4 :k4 20)
;; (test020 10)

(defun test016 (x y z)
  (list x y z))

(defun test017 (x &optional o1 (o2 (cos 0)) (o3 (sin 0) so3))
  (list x o1 o2 o3 so3))

(defun test018 (x &rest r)
  (list x r))

(defun test019 (x &key k1 (k2 (sin 0)) (k3 (cos 0) sk3) ((:k k4)) ((:l k5) (sin 1) sk6) &allow-other-keys)
  (list x k1 k2 k3 k4 k5 sk6))

(defun test020 (x &aux y (z (sin 10)))
  (list x y z))

;; destructuring-bind
;; (test021 '(1 (2 3)))
;; (test022 '(1 (2 3)))

(defun test021 (n)
     (destructuring-bind (&whole w x (y z)) n
       (list w x y z)
       (list w x y z)))

(defun test022 (n)
     (destructuring-bind (x (y z)) n
       (list x y z)
       (list x y z)))

;; do
;; (test023 11)

(defun test023 (n)
  (do ((m)
       (k (- 0 n))
       (i (- n 10) (1+ i)))
      ((= i n) (list m k i n))
    (princ i)
    (terpri)
    (princ n)))
       
;; do*
;; (test024 11)

(defun test024 (n)
  (do* ((m)
	(k (- 0 n))
	(i (- n 10) (1+ i)))
      ((= i n) (list m k i n))
    (princ i)
    (terpri))
    (princ n))

;; do-all-symbols

;; (test025)
(defun test025 ()
  (let ((n 1))
    (do-all-symbols (s)
      (princ s)
      (setf n (+ n 1))
      (when (= n 4) (return-from test025)))))

;; do-external-symbols
;; (test026)
(defun test026 ()
  (let ((n 1))
    (do-external-symbols (s)
			 (princ s)
			 (setf n (+ n 1))
			 (when (= n 4) (return-from test026)))))

;; dolist
;; (test027 '(a b c d))

(defun test027 (l)
  (dolist (v (append l l) (append l l l)) (princ v))
  (dolist (v l) (princ v)))

;; dotimes
;; (test028 10)

(defun test028 (n)
  (dotimes (i (+ n 2) (+ n n)) (princ i))
  (dotimes (i n) (princ i)))

;; do-symbols
;; (test029)

(defun test029 ()
  (let ((n 1))
    (do-symbols (s)
      (princ s)
      (setf n (+ n 1))
      (when (= n 4) (return-from test029)))))

;; ecase
;; (test 10)

(defun test030 (n)
  (ecase (* n 2)
    (10 (list 'ten))
    (20 (list 'twenty))
    (30 (list 'thirty))))

;; etypecase
;; (test031 10)

(defun test031 (n)
  (etypecase (+ n (/ 1 3))
    (integer (list 'is 'integer))
    (rational (list 'is 'rational))
    (complex (list 'is 'complex))))

;; ctypecase
;; (test032 10)


      
(defun test032 (n)
  (ctypecase (+ n (/ 1 3))
    (integer (list 'is 'integer))
    (rational (list 'is 'rational))
    (complex (list 'is 'complex))))


;; flet
;; (test033 3)

(defun test033 (n)
  (flet ((test (n) (if (zerop n) 100 200)))
    (test n)))

;; if
;; (test034 10)

(defun test034 (n)
  (if (= n 10) (princ 'ok))
  (if (= n 10) (princ 'ok) (princ 'nok))
  (if (< n 10) (princ 'ok) (princ 'nok)))


;; generic-flet
;; (test035 1 2)


(defun test035 (n m)
  (generic-flet ((tst (s1 &optional s2)
		      (:method ((n integer) &optional m) (+ n m))
		      (:method ((n string) &optional m) (list "+" n m))))
		(tst 1 2)
		(tst "een" "twee")))


;; generic-function
;; (test036)

(defun test036 ()
  (let ((f (generic-function (s1 &optional s2)
			     (:method ((n integer) &optional m) (+ n m))
			     (:method ((n string) &optional m) (list '+ n m)))))
    (funcall f 1 2)
    (funcall f "een" "twee")))

;; generic-labels
;; (test037 1 2)

(defun test037 (n m)
  (generic-labels ((tst (s1 &optional s2)
			(:method ((n integer) &optional m) (+ n m))
			(:method ((n string) &optional m) (list "+" n m))))
		  (tst 1 2)
		  (tst "een" "twee")))


;; handler-bind
;; (test038)

(defun test038 ()
  (ignore-errors
    (handler-bind ((division-by-zero #'(lambda (n) (format t "Error ~A " n))))
		  (/ 1 0))))

;; handler-case
;; (test039)

(defun test039 ()
  (ignore-errors
    (handler-case (/ 1 0)
		  (division-by-zero (n) (format t "Error ~A " n))
		  (error (m) (format t "Error ~A " m)))))

;; ignore-errors
;; (test040)

(defun test040 ()
  (ignore-errors
    (/ 1 3)
    (/ 1 0)))

;; incf
;; (test041 10)

(defun test041 (n)
  (incf n 20)
  n)

;; labels
;; (test042 3)

(defun test042 (n)
  (labels ((fac (n) (if (zerop n) 1 (* n (fac (- n 1))))))
    (fac n)))

;; lambda
;; (test043 '(1 2 3 4))

(defun test043 (l)
  (mapcar #'(lambda (n) (+ n n)) l))

;; let
;; (test044)

(defun test044 ()
  (let (n
	(m 10)
	(k 20))
    (princ (list n m k)))
  (princ "Ok"))


;; let*
;; (test045 10)

(defun test045 (n)
  (let* ((k (+ n n))
	 (m (+ k k))
	 (c (* k m)))
    (princ (list n k m c)))
  (princ "Ok"))


;; locally
;; (test046 10)

(defun test046 (n)
  (locally (declare (integer n))
	   (princ (+ n n))))

;; loop
;; (test047 5)

(defun test047 (n)
  (loop
    (setf n (- n 1))
    (when (zerop n) (return))))


;;macrolet
;; (test048 10)

(defun test048 (n)
  (macrolet ((cosinus (n) `(cos ,n)))
    (cosinus (+ n n))))


;; multiple-value-bind
;; multiple-value-call
;; multiple-value-list
;; multiple-value-prog1
;; multiple-value-setq
;; (test049)

(defun test049 ()
  (multiple-value-bind (n m) (values (+ 1 2) (/ 3 4))
    (list
     (multiple-value-call #'(lambda (i j) (+ i j)) (values n m))
     (multiple-value-list (values n m))
     (multiple-value-setq (n m) (values (+ n n) (+ m m)))
     (multiple-value-prog1 (values n m) (+ n m)))))

;; or
;; (test050)

(defun test050 ()
  (list (or)
	(or 1 2)
	(or (+ 1 3) (- 1 1) nil)))

;; prog
;; (test051)

(defun test051 ()
  (prog (n
	 (m 10))
	(setf n (list m m))
	(list n m)))

;; prog*
;; (test052)

(defun test052 ()
  (prog* ((n 10)
	  (m (* n n)))
	 (list n m)))

;; prog1
;; (test053)

(defun test053 ()
  (prog1 (cos 1)
    (sin 1)
    (sin 2)))

;; prog2
;; (test054)

(defun test054 ()
  (prog2
      (sin 1)
      (sin 2)
    (sin 3)))

;; progn
;; (test055)

(defun test055 ()
  (progn
    (sin 1)
    (sin 2)
    (sin 3)))

;; progv
;; (test056)

(defun test056 ()
  (progv (list 'n 'm) (list 1 2) (list n m)))

;; psetf
;; (test057 '(1 2 3))

(defun test057 (l)
  (psetf (first l) (1+ (first l)) (second l) (1+ (second l)))
  l)

;; psetq
;; (test058)

(defun test058 ()
  (let ((n nil) (m nil))
    (psetq n 10 m 20)
    (list n m)))

;; push
;; pushnew
;; (test059 nil)

(defun test059 (l)
  (push (+ 1 2) l)
  (pushnew (+ 1 2) l))

;; return
;; return-from
;; (test060 3)

(defun test060 (n)
  (loop (when (zerop n) (return (+ n n)))
    (setf n (- n 1)))
  (if (zerop n) (return-from test060)))

;; setf
;; setq
;; (test061)

(defun test061 ()
  (let ((n '(a b))
	(n1 nil)
	(n2 nil))
    (setf (first n) (+ 1 1) (second n) (+ 2 2))
    (setq n1 (+ 1 1) n2 (+ 2 2))
    (list n n1 n2)))



;; symbol-macrolet
;; (test062)

(defun test062 ()
  (let ((a 20))
    (symbol-macrolet ((n `(cos ,a))) (list n n))))


;; tagbody
;; (test063)

(defun test063 ()
  (tagbody (sin 1) (sin 2)))

;; the
;; (test064)

(defun test064 ()
  (the integer (+ 1 2)))


;; unless
;; (test065)

(defun test065 ()
  (unless (= 10 11)
    (sin 1)
    (sin 2)))

;; unwind-protect
;; (test066)

(defun test066 ()
  (unwind-protect
      (return-from test066 (+ 1 2))
    (sin 2)
    (sin 3)))

;; when
;; (test067 10)

(defun test067 (n)
  (when (= n 10) (return-from test067 100))
  200)

;; with-accessors
;; (test068)

(defclass testclass ()
  ((field1 :accessor field1)
   (field2 :accessor field2)))

(defun test068 ()
  (let ((a (make-instance 'testclass)))
    (setf (field1 a) 10)
    (setf (field2 a) 20)
    (with-accessors ((v1 field1) (v2 field2)) a
		    (princ v1)
		    (princ v2)
		    (terpri))))


;; with-compilation-unit
;; (test069)

(defun test069 ()
  (with-compilation-unit (:override nil) (sin 1) (sin 2)))


;; with-hash-table-iterator
;; (test070)

(defun test070 ()
  (let ((h (make-hash-table)))
    (setf (gethash 'a h) 10)
    (setf (gethash 'b h) 20)
    (with-hash-table-iterator (mh h)
			      (princ (mh))
			      (princ (mh)))))

;; with-input-from-string
;; (test071 1 1)

(defun test071 (a b)
  (setf b "Een twee drie vier")
  (with-input-from-string (v b :start a)
			  (princ (read v))
			  (princ (read v))
			  (terpri)))


;; with-open-file
;; (test072)

(defun test072 ()
  (let ((a nil))
    (with-open-file (h (setf a "log") :direction :input)
		       (princ (read h))
		       (princ (read h))
		       (terpri))))

;;  with-open-stream
;; (test073)

(defun test073 ()
  (with-open-stream (v (open "log" :direction :input))
		    (princ (read v))
		    (princ (read v))
		    (terpri)))

;; with-output-to-string
;; (test074)

(defun test074 ()
  (with-output-to-string (v)
			 (format v "Dit is een test")
			 (format v "Dit is een proef")))


;; with-simple-restart
;; (test075 1)

(defun test075 (level)
  (with-simple-restart
   (abort "Exit command level ~D." level)
   (princ (sin 1))
   (abort)
   (sin 2)))



;; with-slots
;; (test076)

(defun test076 ()
  (let ((a (make-instance 'testclass)))
    (setf (field1 a) 10)
    (setf (field2 a) 20)
    (with-slots ((v1 field1) (v2 field2)) a
		(princ v1)
		(princ v2)
		(terpri))))

    
  
  














(defun test ()
  (test001 1)
  (test001 0)
  (test007 0)
  (test007 (/ 1 2))
  (test007 2)
  (test008 0)
  (test008 1)
  (test010 0)
  (test010 1)
  (test010 2)
  (test011 '(3))
  (make-instance 'test012)
  (make-instance 'test013)
  (test014 1)
  (test014 0.5)
  (test014 "one")
  (test015 10)
  (test016 1 2 3)
  (test017 1)
  (test017 1 2)
  (test017 1 2 3)
  (test018 1 2 3)
  (test019 10 :k1 4 :k4 20)
  (test020 10)
  (test021 '(1 (2 3)))
  (test022 '(1 (2 3)))
  (test023 11)
  (test024 11)
  (test025)
  (test026)
  (test027 '(a b c d))
  (test028 10)
  (test029)
  (test030 10)
  (test031 10)
  (test032 10)
  (test033 3)
  (test034 10)
  (test035 1 2)
  (test036)
  (test037 1 2)
  (test038)
  (test039)
  (test040)
  (test041 10)
  (test042 3)
  (test043 '(1 2 3 4))
  (test044)
  (test045 10)
  (test046 10)
  (test047 5)
  (test048 10)
  (test049)
  (test050)
  (test051)
  (test052)
  (test053)
  (test054)
  (test055)
  (test056)
  (test057 '(1 2 3))
  (test058)
  (test059 nil)
  (test060 3)
  (test061)
  (test062)
  (test063)
  (test064)
  (test065)
  (test066)
  (test067 10)
  (test068)
  (test069)
  (test070)
  (test071 1 1)
  (test072)
  (test073)
  (test074)
  (test075 1)
  (test076)
  )


;;
;; Test of backquote
;;

(defmacro testm (n)
  `(cos ,n))