; .EnTete "Le←Lisp version 15.2" " " "Utilitaires communs a` tous les tests"
; .EnPied "testcomm.ll" % ""
; .SuperTitre "Utilitaires communs a` tous les tests"
; .Auteur "Je'ro↑me Chailloux"

; .Centre "*****************************************************************"
; .Centre " Ce fichier est en lecture seule hors du projet  ALE  de l'INRIA "
; .Centre "Il est maintenu par : ILOG S.A. 9 rue Royale, 75008 Paris, France"
; .Centre "*****************************************************************"
 

(unless (>= (version) 15.2)
        (error 'load 'erricf 'testcomm))
(setq #:sys-package:colon 'testcomm)

; .Section "Les constantes nume'riques"
(defvar pi 3.14159265358979323)
(defvar pi/2 (/ pi 2.))
(defvar pi/4 (/ pi 4.))
(defvar eNeper 2.718281828459045)

; .Section "Les comparaisons flottantes/complexes"
(defvar :epsilon 
        ; valeur de la pre'cision flottante
        (if (eq 0. 0.)
            (power 10. -6)        ; 31 bits
            (power 10. -14)))     ; 64 bits

(de :equalp (x y)
    ; teste 2 valeurs (en faisant attention a` la pre'cision des
    ; nombres flottants et complexes).
    (car
        (catcherror t
            (cond ((or (floatp x) (floatp y)) 
                   (<= (abs (- (float x) (float y))) :epsilon))
                  ((and (numberp x) (numberp y)) 
                    (if (and (typefn 'complexp) (complexp x) (complexp y))
                        (and (:equalp (realpart x) (realpart y))
                             (:equalp (imagpart x) (imagpart y)))
                        (= x y)))
                  (t (equal x y))))))


; .Section " Les fonctions communes de test"
(de testfn (?speaki . file)
    ; si file n'est pas fourni on lit sur le canal d'entre'e courant
    ;
    ; la fonction de test
    ; ?speaki = t  si on desire un "log" du resultat.
    ;
    (if file
        (with ((inchan (openi (car file))))
              (dotestfn))
        (dotestfn)
        (exit eof)))

(defvar :error-occured ())

(de dotestfn ()
    ; On utilise certaines variables globales, ce qui permet un debug facile
    ; - testfnlu     : la forme a tester
    ; - testfnval    : la valeur theorique
    ; - testfnres    : la valeur calculee
    (let ((#:sys-package:itsoft 'test))
      (setq #:system:redef-flag t)      ; faire taire les messages
      (setq :error-occured ())
      (untilexit eof
                 ; pour egalement traiter les erreurs
                 (setq testfnlu (tread))
                 (if (and (consp testfnlu) (eq (car testfnlu) 'test-serie))
                     (progn
                       (if (cddr testfnlu)
                           (setq ?speaki (caddr testfnlu)))
                       (ifn ?speaki
                            (print "      " (cadr testfnlu))
                            (terpri) (print (cadr testfnlu)) (terpri)))
                   (setq testfnres (tread))
                   (setq testfnval (catcherror t (eval testfnlu)))
                   (when ?speaki
                         (print "          " testfnlu " = " testfnres))
                   (unless (:equalp (car testfnval) testfnres)
			   (setq :error-occured t)
			   (prin "***** la valeur de " testfnlu )
			   (prin " devrait e↑tre " testfnres)
			   (prin " et non pas    " (car testfnval))
			   (terpri)) ))))

(de testcp (?speaki . file)
    ; si file n'est pas fourni on lit sur le canal d'entre'e courant
    ;
    ; ?speaki = t  si on desire un "log" du resultat.
    ; ?speakc = t  si on desire plutot tester le compilateur.
    ;
    ; On utilise certaines variables globales, ce qui permet un debug facile
    ; - testcplu     : la forme a tester
    ; - testcpval    : la valeur theorique
    ; - testcpres    : la valeur calculee
    (setq #:system:redef-flag t)      ; pour faire taire les messages
    ;    (debug t)
    (terpri)
    (print "===== AVEC #:compiler:open-p")
    (terpri)
    (let ((#:compiler:open-p t))
         (testcp1))
    (terpri)
    (print "===== SANS #:compiler:open-p")
    (terpri)
    (let ((#:compiler:open-p ()))
         (testcp1)))

(de testcp1 ()
    (if file
        (with ((inchan (openi (car file))))
              (dotestcp1))
        (dotestcp1)
        (exit eof)))

(de dotestcp1 ()
    ; pour le lancer plusieurs fois.
    (let ((#:sys-package:itsoft 'test) (cpfn))
      (untilexit eof
                 ; pour egalement traiter les erreurs
                 (setq testcplu (tread))
                 (if (and (consp testcplu)
                          (eq (car testcplu) 'test-serie))
                     (progn
                       (if (cddr testcplu)
                           (setq ?speaki (caddr testcplu)))
                       (ifn ?speaki
                            (print "      " (cadr testcplu))
                            (terpri) (print (cadr testcplu)) (terpri)))
                   (setq testcpres (tread))
                   (unless (and (consp testcpres)
                                (symbolp (car testcpres))
                                (or (memq (car testcpres) '(lambda flambda))
                                    (eq (index "err" 
                                               (string (car testcpres)) 0) 0)))
                           (when ?speaki 
                                 (print "        " 
                                        testcplu " ?= " testcpres))
                           (setq cpfn 'cp-foo-fnt)
                           (remfn cpfn)
                           (eval (list 'de cpfn () testcplu))
                           (setq testcpval
                                 (catcherror () 
                                             (compiler cpfn () () ())
                                             'ok))
                           (if (or (atom testcpval)
                                   (nequal testcpval '(ok)))
                               (print "*** erreur dans la compilation de "
                                      testcplu)
                             (setq testcpval 
                                   (catcherror () (funcall cpfn)))
                             (ifn (:equalp (car testcpval) testcpres)
                                  (progn (print "***** la valeur de " testcplu)
                                         (print " devrait e↑tre " testcpres)
                                         (print " pas           " 
                                                (car testcpval))))))))))

(de #:test:syserror (f m a)
    ; retourne la liste (nom-de-l'erreur fnt)
    (err (list (list m f a))))

(de tread ()
    (car (catcherror t (read))))

(add-feature 'testcomm)