; .EnTete "Le-Lisp (c) version 15.2" " " "Le paragrapheur"
; .EnPied "pretty.ll" "J-%" " "
; .Annexe J "Le paragrapheur"
; .nr % 1
;
; .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: pretty.ll,v 4.1 88/01/13 12:23:18 kuczynsk Rel213 $"
; Paragraphe une S-expression quelconque, conside're'e comme
; un programme (mais reste suffisamment paranoiaque pour ne
; jamais perdre de l'information).
(unless (>= (version) 15.21)
(error 'load 'erricf 'pretty))
; Tous les symboles pre'ce'de's de : seront cre'e's dans le package PRETTY.
(defvar #:sys-package:colon 'pretty)
(add-feature 'pretty)
; .Section "Les fonctions internes"
(defvar :quotelevel 0)
(defvar :quotelength 0)
(de :p (l)
; paragraphe l'expression <l>
(let ((f (getfn (type-of l) 'pretty ())))
(cond
((and f (neq f 'pretty))
; essaie de lancer un paragrapheur de type e'tendu
(funcall f l))
((atom l) (prin l))
((and (eq (car l) 'QUOTE)
(consp (cdr l))
(null (cddr l)))
; le cas de (QUOTE s) => 's
(princn #/')
(with ((printlevel :quotelevel)
(printlength :quotelength))
(prin (cadr l))))
((and (consp (car l))
(eq (caar l) 'LAMBDA)
(consp (cdar l))
(listp (cadar l))
(listp (cddar l))
(listp (cdr l))
(null (cdr (last (cadar l))))
(null (cdr (last (cdr l))))
(eq (length (cadar l))
(length (cdr l))))
; le cas ((LAMBDA ...) ...) => (LET ...)
; en ve'rifiant qu'il n'y a pas perte d'information.
(:p (mcons 'let
(mapcar 'list (cadar l) (cdr l))
(cddar l))))
((and (if (symbolp (car l))
(neqn (ptype (car l)) 3)
t)
(:inlinep l)))
(t (let ((f (car l))
(l (cdr l)))
(princn #/( )
(:p f)
(selectq (if (symbolp f)
(ptype f)
t)
(1 (:progn))
(2 (:p1) (:progn))
(3 (:p1) (:p1) (:progn))
(4 (:cond))
(5 (:p1) (:cond))
(6 (with ((lmargin (add (lmargin) 5)))
(while (consp l)
(:p1)
(:p1)
(when l (terpri)))))
(7 (:p1) (:tagbody))
(t (:progn)))
(:pdot))))))))))
(de :pdot ()
; si l'expression <l> n'est pas nulle, imprime une paire pointe'e.
(when l
(princn #\sp)
(princn #/. )
(princn #\sp)
(prin l))
(princn #/) ))
(de :p1 ()
; e'dite l'e'le'ment suivant (sauf le 1er) avec test
(when (consp l)
(with ((lmargin (:lmargin f)))
(princn #\sp)
(:p (nextl l)))))
(de :progn ()
; paragraphe le PROGN courant
; ne traite que les listes bien forme'es
(with ((lmargin (:lmargin f)))
(while (consp l)
(if (numberp (car l))
(:p1)
(if (lt (outpos) (lmargin))
(outpos (lmargin))
(terpri))
(:p (nextl l))))))
(de :tagbody ()
; paragraphe le TAGBODY courant.
(with ((lmargin (:lmargin f)))
(while (consp l)
(if (atom (car l))
(with ((lmargin (sub (lmargin)
(imin (lmargin) 7))))
(terpri)
(:p1))
(if (lt (outpos) (lmargin))
(outpos (lmargin))
(terpri))
(:p (nextl l))))))
(de :cond ()
; paragraphe le COND courant
(with ((lmargin (add (lmargin) 3)))
(while (consp l)
(terpri)
(if (:inlinep (car l))
(nextl l)
(let ((l (nextl l)) (f t))
(princn #/( )
(when (consp l) (:p (nextl l)))
(when l (:progn))
(:pdot)))))))
(de :lmargin (f)
; calcule la nouvelle marge gauche
(add (lmargin)
(cond ((listp f) 1)
((vectorp f) 1)
((lt (lmargin) (div :sizeline 2))
(if (lt (plength f) 8)
(add (plength f) 2)
4))
((lt (lmargin) (scale :sizeline 3 4))
2)
(t 0))))))))
(de :inlinep (l)
; si <l> rentre dans la ligne imprime <l>
; sinon e'chappement de nom :inlinep et retourne ()
(let ((:outpos (outpos)))
(if (tag :inlinep
(let ((#:sys-package:itsoft
(cons 'pretty #:sys-package:itsoft)))
(prin l)
t))
t
(fillstring (outbuf) :outpos #\sp)
(outpos :outpos)
())))
(de #:pretty:eol ()
; le gestionnaire de fin de ligne de PRETTY
(exit :inlinep ()))
; .Section "Les fonctions utilisateur"
(de pprint (s)
; fonction utilisateur : paragraphe l'expression <s>
(with ((lmargin (lmargin)))
(let ((#:system:print-for-read t) ; Impression pour la lecture
(#:system:print-package-flag ; Packages a la demande
(or #:system:print-package-flag t))
(:sizeline (sub (rmargin) (lmargin)))
(f ()))
(:p s))
(terpri))
s)
(de pprin (s)
; ne positionne rien
(let ((:sizeline (sub (rmargin) (lmargin))))
(:p s)))
(df pretty :l
; paragraphe la liste de fonctions <l>
(mapc (lambda (l)
(cond ((memq l #:trace:trace)
(print "; " l " est tracee")
(terpri)
(pprint (:get-plist-def l 'trace)))
((getprop l 'resetfn)
(pprint (:get-plist-def l 'resetfn)))
(t (pprint (getdef l))))
(terpri))
:l))
(de :get-plist-def (symbol prop)
(makedef symbol
(car (getprop symbol prop))
(cdr (getprop symbol prop))))
(df prettyf :l
; comme PRETTY mais le re'sultat est sorti sur fichier
; le nom du fichier est donne' en 1er argument
(with ((outchan (openo (car :l))))
(apply 'pretty (cdr :l))
(close (outchan))
(car :l)))
(de prettyend ()
(mapc 'remob (oblist '#.#:sys-package:colon))
(rem-feature 'pretty)
(libautoload pretty pprint pprin pretty prettyf prettyend)
'prettyend)
; .Section "Pose des ptypes standard"
(let ((x '
(
+ 1
- 1
* 1
append 1
and 1
calln 1
catenate 1
concat 1
list 1
max 1
mcons 1
min 1
or 1
plus 1
prin 1
print 1
prog1 1
progn 1
protect 1
times 1
any 2
block 2
call 2
catcherror 2
do 2
do* 2
every 2
evexit 2
evtag 2
exit 2
funcall 2
if 2
ifn 2
lambda 2
let 2
lets 2
let* 2
map 2
mapc 2
mapcar 2
maplist 2
mapcon 2
mapcan 2
repeat 2
slet 2
tag 2
unless 2
until 2
untilexit 2
when 2
while 2
with 2
de 3
defun 3
df 3
dm 3
dmc 3
dmd 3
dms 3
defmacro 3
defsharp 3
letn 3
backtrack 3
cond 4
selectq 5
setq 6
setqq 6
psetq 6
tagbody 7
)))
(while x
(ptype (nextl x) (nextl x)))))