;;; .EnTete "Le←Lisp (c) version 15.2" " " "Test des fonctions d'impression"
;;; .EnPied "testprint.ll" "%" ""
;;;
;;; .SuperTitre "Test des fonctions d'impression"
;;;
;;;
;;; .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: testprint.ll,v 4.5 88/11/30 15:27:35 chaillou Exp $"

(unless (>= (version) 15.2)
        (error 'load 'errifc 'testprint))

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

(defvar :speak? ())    ; pour de'bogger le test lui-me↑me.

(setq #:system:print-for-read ())

(setq pfile "/tmp/testprint.ll")
(comline (catenate "rm -f " pfile))

; .Section "Test du PRINT normal"

(print "        [Tests des fonctions d'impression]")

(df :testprint (printform formattendue)
    (let ((file pfile)
          (relu))
      (setq formattendue (eval formattendue))
      (with ((outchan (openo file)))
	    (eval printform)
	    (terpri)
	    (close (outchan)))
      (with ((inchan (openi file)))
	    (setq relu (car (catcherror () (readstring))))
	    (close (inchan)))
      (when :speak?
	    (print (format ()
			   "~S ~35T doit imprimer ~50T<~A>"
			   printform
			   formattendue)))
      (unless (equal relu formattendue)
	      (prin " ** " printform " devrait imprimer ")
	      (let ((#:system:print-for-read t))
		(prin formattendue))
	      (print " pas " relu))))

(:testprint (print "asd") "asd")
(:testprint (print 'asd)  "asd")
(:testprint (let ((#:system:print-for-read t)) (print "asd"))   """asd""")
(:testprint (let ((#:system:print-for-read t)) (print '|0129|)) "|0129|")
(:testprint (print 123.45)      "123.45")
(:testprint (print 123.4567)    "123.4567")
(:testprint (print 1 2 3)       "123")
(:testprint (print 'a 2 "%%")   "a2%%")
(:testprint (print '#(1.2))     "#(1.2)")
(:testprint (print '#("a"))     "#(a)")
(:testprint (let ((#:system:print-for-read t)) (print 1 2 3))   "1 2 3")
(:testprint (let ((#:system:print-for-read t)) (print 'a 2 "%%"))"a 2 ""%%""")

(:testprint (print) "")
(:testprint (apply 'print ()) "")
(:testprint (prin) "")

(:testprint (prin 34) "34")
(:testprint (progn (prin "foo")(terpri)) "foo")

(:testprint (terpri) "")

(:testprint (prinflush 123) "123")
(:testprint (prinflush "123") "123")

(:testprint (princn #/a) "a")
(:testprint (princh '|=|) "=")
(:testprint (with ((lmargin 0) (rmargin 10) (printline 1))
                  (princn #/a 20))
            "aaaaaaa...")
(:testprint (with ((lmargin 0) (rmargin 10) (printline 1))
                  (prin 'foo) (princh "a" 20))
            "fooaaaa...")

(:testprint (with ((printlength 2))(print '(1 2 3 4))) "(1 2 ...")
(:testprint (with ((printlevel 2)) (print '(1 (2 (3 (4)))))) "(1 (2 &))")

(de #:tf:flush ()
    (setq #:tf:outbuf (copy (outbuf))))

(:testprint (with ((lmargin 0)
		   (rmargin (add1 (slen (outbuf)))))
		  (repeat (slen (outbuf)) (princn #/a)))
	    (makestring (slen (outbuf)) #/a))

; .Section "Test des accolades"

(when (featurep 'abbrev)
      (print "        [Tests d'impression des abre'viations]")
      (unless (abbrevp 'ffoo)
              (defabbrev ffoo #:bar:gee)))

(when (featurep 'abbrev)
      (:testprint (prin '{ffoo}:fuu) "{ffoo}:fuu")
      (:testprint (prin '{ffoo}:fuu:#[1 2]) "#:bar:gee:fuu:#[1 2]")
      (:testprint (let ((#:system:print-for-read t))
                       (prin '{ffoo}:"abc"))
                  "#:bar:gee:""abc""")
      (:testprint (with ((lmargin 0)
                         (rmargin 20)
                         (printline 1))
                        (prin '({ffoo}:fuu {ffoo}:fee {ffoo}:fii)))
                  "({ffoo}:fuu {ffo...")
      (:testprint (with ((lmargin 0)
                         (rmargin 25)
                         (printline 1))
                        (prin '({ffoo}:fuu {ffoo}:fee {ffoo}:fii)))
                  "({ffoo}:fuu {ffoo}:fe...")
      (flet ((#:null:prin (x) (pratom 'nil)))
            (:testprint (prin ()) "nil")))


; .Section "Test du PRETTY-PRINT"

(print "        [Tests du PRETTY-PRINT]")

(defvar :liste-de-lignes ())

(de :eol ()
    (newl :liste-de-lignes (substring (outbuf) 0 (outpos)))
    (fillstring (outbuf) 0 #\sp (outpos))
    (outpos 0))


(de :testpprint ()
    (let ((lu)
          (val)
          (the))
         (with ((rmargin 60) (lmargin 0))
               (untilexit eof
		   (setq lu (read))
                   (when (eq lu ()) (exit eof))
                   (setq the (read))
                   (when :speak?
                         (print lu " = " the))
                   (setq :liste-de-lignes ())
                   (let ((#:sys-package:itsoft
			  (cons 'testprint #:sys-package:itsoft)))
		     (pprint lu))
                   (setq val (reverse :liste-de-lignes))
                   (when (nequal val the)
                         (print " ** le PPRINT de "
			        lu " est " the " pas " val))
		   ))))

(:testpprint)

1                   ("1")
a                   ("a")
|(|                 ("|(|")
|a||a|              ("|a||a|")
|0129|              ("|0129|")
"ab c"              ("""ab c""")

(quote)             ("(quote)")
(quote . a)         ("(quote . a)")
(quote a)           ("'a")
(quote a . b)       ("(quote a . b)")

((lambda . x))      ("((lambda . x))")
((lambda x))        ("((lambda x))")
((lambda x) 1 . 2)  ("((lambda x) 1 . 2)")
((lambda (x y) . 1) 2 3)      ("((lambda (x y) . 1) 2 3)")
((lambda (x) x) 1 2)          ("((lambda (x) x) 1 2)")
((lambda (x y) ()) 1 2)       ("(let ((x 1) (y 2)) ())")

()

(print "        [Fin du test des impressions]")