;;; .EnTete "Le-Lisp (c) version 15.2" " " "Test de la Trace et du Pas-a`-pas"
;;; .EnPied "testtrace.ll" "%" " "
;;;
;;; .SuperTitre "Test de la Trace et du Pas-a`-pas"
;;;
;;;
;;; .Centre "*****************************************************************"
;;; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA.  "
;;; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
;;; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA                 "
;;; .Centre "*****************************************************************"
;;;
;;; .Centre "$Header: testtrace.ll,v 4.5 88/11/18 14:52:52 neidl Exp $"

(unless (>= (version) 15.2)
        (error 'load 'erricf 'testtrace))

(setq #:sys-package:colon 'testtrace)

;;; Pour rendre les tests +/- causant
(setq :speak? ())

;;; Une fonction testtrace qui teste en dur les messages "normaux"!!
(de :testtrace (file liste-of-trace)
    ;; FILE est le fichier issu de la trace
    ;; LISTE-OF-TRACE est la liste des affichages attendus de la trace
    ;; SPEAK? fait causer :testtrace s'il vaut T
    (with ((inchan (openi (temporary-file-pathname file))))
       (tag eof
          (while t
	    (let ((form (readstring))
		  (trueform (nextl liste-of-trace)))
	      (when :speak?
		    (print "La forme obtenue par trace de " file ": " form)
		    (print "La forme attendue: " trueform))
	      (ifn (equal form trueform)
		   (print "**** la trace de " file " devrait e↑tre <"
			  trueform ">, pas <" form ">")
		   (when :speak? (print " OK"))
		   ))))
       ))

;;; Une macro write-trace qui sort la trace sur fichier:
(defmacro :write-trace (file . fn)
  `(with ((outchan (openo ,(temporary-file-pathname file))))
	 (let ((*trace-output* (outchan))
	       (*trace-itsoft* 'testtrace)
	       (#:sys-package:itsoft 'testtrace))
	   (mapc (lambda (a)
		   (print (car (catcherror () (eval a)))))
		 ',fn))
	 (close (outchan))))

(de :syserror (function message args)
    ;; retourne la liste (nom-de-l'erreur fnt)
    (err (list (list message function args))))

(print "          [Test de trace]")

;;; trace d'une EXPR:
(de :foo1 (x)
  (if (le x 0) ()
    (cons x (:foo1 (1- x)))))

(setq #:system:print-package-flag t)

(:write-trace "foo1"
	      (trace :foo1)
	      (:foo1 2)
	      (untrace :foo1))

(:testtrace "foo1"
	   '("(#:testtrace:foo1)"
	     "#:testtrace:foo1 ---> x=2 " "#:testtrace:foo1 ---> x=1 "
	     "#:testtrace:foo1 ---> x=0 " "#:testtrace:foo1 <--- ()"
	     "#:testtrace:foo1 <--- (1)" "#:testtrace:foo1 <--- (2 1)"
	     "(2 1)"
	     "(#:testtrace:foo1)" ))


;;; trace d'une FEXPR:
(df :foo2 (x) (list x))

(:write-trace "foo2"
	      (trace :foo2)
	      (:foo2 (cons 1 2))
	      (untrace :foo2))

(:testtrace "foo2"
	  '("(#:testtrace:foo2)"
	    "#:testtrace:foo2 ---> x=(cons 1 2) "
	    "#:testtrace:foo2 <--- ((cons 1 2))" 
	    "((cons 1 2))"
	    "(#:testtrace:foo2)"))

;;; trace d'une fonction &NOBIND:

(de :foo3 &nobind (list (arg)))

(:write-trace "foo3"
	      (trace :foo3))

(:testtrace "foo3"
	    '("(errtnb trace #:testtrace:foo3)"))


;;; trace d'une MACRO:
(defmacro :foo4 (x) `(cons ,x ,x))

(:write-trace "foo4"
	      (trace :foo4)
	      (:foo4 3)
	      (untrace :foo4))

(:testtrace "foo4"
	    '("(#:testtrace:foo4)"
	      "#:testtrace:foo4 ---> x=3 "
	      "#:testtrace:foo4 <--- (cons 3 3)"
	      "(3 . 3)"
	      "(#:testtrace:foo4)" ))

;;; trace d'une fct compilee puis redefinie
;;; Pour verifier que la fct ne change pas d'etat.
(de :foo5 () 2)
(compile :foo5)
(setq :save-redef #:system:redef-flag)
(protect 
    (progn 
      (setq #:system:redef-flag t)
      (:write-trace "foo5"
		    (typefn ':foo5)
		    (de :foo5 () 33)
		    (trace :foo5)
		    (:foo5)
		    (untrace)
		    (typefn ':foo5))
      (:testtrace "foo5"
		  '("subr0"
		    "#:testtrace:foo5"
		    "(#:testtrace:foo5)"
		    "#:testtrace:foo5 ---> "
		    "#:testtrace:foo5 <--- 33"
		    "33"
		    "(#:testtrace:foo5)"
		    "subr0")))
    ;; restore the previous value of #:system:redef-flag
    (setq #:system:redef-flag :save-redef))
      
;;; tracepuis detrace d'une subr
(:write-trace "foo6"
	      (trace rplacd)
	      (rplacd '(1 1) 2)
	      (untrace)
	      (rplacd '(1 1) 2))

(:testtrace "foo6"
	    '("(rplacd)"
	      "rplacd ---> (1 1) 2 "
	      "rplacd <--- (1 . 2)"
	      "(1 . 2)"
	      "(rplacd)"
	      "(1 . 2)"))

(print "          [Fin du test de trace]")
(print "          [Test de step]")

;;; test de step.
(setq #:step:auto-step t)

;;; step d'une fonction recursive:
(de :bar1 (x) (if (le x 0)()(cons x (:bar1 (1- x)))))

(:write-trace "bar1" (step (:bar1 3)))

(:testtrace "bar1"
'(
"  2 <- 3"
"    4 <- 3"
"    4 <- 0"
"   3 <- ()"
"    4 <- 3"
"      6 <- 3"
"     5 <- 2"
"       7 <- 2"
"       7 <- 0"
"      6 <- ()"
"       7 <- 2"
"         9 <- 2"
"        8 <- 1"
"          10 <- 1"
"          10 <- 0"
"         9 <- ()"
"          10 <- 1"
"            12 <- 1"
"           11 <- 0"
"             13 <- 0"
"             13 <- 0"
"            12 <- 0"
"            12 <- ()"
"           11 <- ()"
"          10 <- ()"
"         9 <- (1)"
"        8 <- (1)"
"       7 <- (1)"
"      6 <- (2 1)"
"     5 <- (2 1)"
"    4 <- (2 1)"
"   3 <- (3 2 1)"
"  2 <- (3 2 1)"
" 1 <- (3 2 1)"
"(3 2 1)"
))

;;; step d'une fonction &NOBIND au toplevel:
(de #:tt:bar2 &nobind (list (arg)))

(:write-trace "bar2" (step (#:tt:bar2 1 11 111)))

(:testtrace "bar2" '(
" ** step : je ne peux pas suivre une fonction &NOBIND : (#:tt:bar2 1 11 111)"
" 1 <- (3)"
"(3)"
))

;;; step d'une fonction &NOBIND, appelle'e:
(de :bar3 () (list (#:tt:bar2 3 2 1)))

(:write-trace "bar3" (step (:bar3)))

(:testtrace "bar3" (list
"   ** step : je ne peux pas suivre une fonction &NOBIND : (#:tt:bar2 3 2 1)"
"   3 <- (3)"
"  2 <- ((3))"
" 1 <- ((3))"
"((3))"
))

(:write-trace "bar4" (step (unstep (cons 1 2))))
(:testtrace "bar4" '("(1 . 2)"))

(print "          [Fin du test de step]")