;;; .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]")