; .EnTete "Le-Lisp (c) version 15.2" " " "Le compilateur Termcap"
; .EnPied " " "%" " "
; .Chapitre 13 "Le Compilateur Termcap"
;
; .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: termcap.ll,v 4.3 88/04/07 18:22:52 nuyens Exp $"
(unless (>= (version) 15.2)
(error 'load 'erricf 'termcap))
; Tous les symboles pre'ce'de's de : seront cre'e's dans le package TERMCAP.
(defvar #:sys-package:colon 'termcap)
(add-feature 'termcap)
; Programme de ge'ne'ration de terminaux virtuels Le←Lisp
; a` partir de la base de donne'es termcap de UN*X.
; Le nom du fichier qui contient cette base de donne'e
; doit se trouver dans la variable #:system:termcap-file;
; le nom du catalogue qui contient les terminaux virtuels
; dans la variable #:system:virtty-directory
; (voir le fichier initial).
; .Section "Lecture de la base de donne'e TERMCAP"
(de :tgetent (term)
(let ((termcap (getenv "TERMCAP")))
(if (and termcap ; le cas ou la description est dans TERMCAP
(neq #// (chrnth 0 termcap))
(index term termcap 0))
(pname termcap)
(let ((line))
(with ((inchan (openi (or termcap #:system:termcap-file))))
(tag eof
(until (setq line (:index term (:readline) 0)))
(setq line (pname line))
(while (= (car (last line)) #/\)
(setq line (nconc line
(pname (:readline)))))
(eof (inchan))))
line))))
(de :index (term line pos)
(setq pos (index term line pos))
(and pos
(let ((pos2 (+ pos (plength term))))
(if (and (or (= pos 0) (= (chrnth (1- pos) line) #/|))
(or (= (chrnth pos2 line) #/|)
(= (chrnth pos2 line) #/:)))
line
(:index term line (1+ pos))))))
(de :readline ()
(let ((line (readstring)))
(if (or (eqstring line "") (= (chrnth 0 line) #/#))
(:readline)
line)))
; .Section "Transformation TERMCAP -> Liste Lisp"
; Cette fonction prend la liste des caracte`res et retourne
; une paire : la liste des noms de terminaux,
; (le premier est de 2 caracte`res de long (sic))
; et une aliste (nom de l'entre'e, valeur de l'entre'e)
; La valeur de l'entre'e est toujours une liste de codes ascii
; (eventuellement vide).
(de :parse (l)
(let ((alist) (pos 0) (prop))
(while (neq (car l) #/:)
(while (= (car l) #/|) (nextl l))
(until (or (null l) (= (car l) #/|) (= (car l) #/:))
(nextl l)))
; on lit maintenant les caracte'ristiques
(untilexit eoln
(while (memq (nth pos l)
'(#\tab #\sp #\lf #\cr #/\ #/:))
(incr pos))
(setq prop (list (:readcn) (:readcn)))
(selectq (nth pos l)
(#/#
(incr pos)
(setq alist (acons prop (:readnumber) alist)))
(#/=
(incr pos)
; lit une chai↑ne eventuellement pre'ce'de'e par
; {{integer}.integer}{*}
; On jette les nombres obtenus
; (si les terminaux ne suivent pas, tant pis)
(when (digitp (nth pos l))
(:readnumber)
(when (eq (nth pos l) #/.)
(incr pos) (:readnumber))
(if (eq (nth pos l) #/*) (incr pos)))
(setq alist (acons prop (:readstring) alist)))
(#/:
(setq alist (acons prop nil alist)))
(#/@
(incr pos) (setq alist (acons prop t alist)))
(t)))
(nreverse alist)))))))))))
; les fonctions de lecture suivante utilisent les variables globales
; <l> et <pos> qui sont modifie'es.
(de :readcn ()
(incr pos) (when (>= pos (length l)) (exit eoln))
(selectq (nth (1- pos) l)
(#/\
(prog1 (or (cassq (nth pos l)
'((#/E . #\esc) (#/n . #\lf) (#/r . #\cr)
(#/t . #\tab) (#/b . #\bs) (#/f . #↑L)))
(and (digitp (nth pos l))
; lecture en octal d'un nombre
(let ((x (- (nth pos l) #/0)))
(while (digitp (nth (incr pos) l))
(setq x (+ (* x 8)
(- (nth pos l) #/0))))
(decr pos)
x))
; et par defaut
(nth pos l))
(incr pos)))
(#/↑
(prog1 (logand 31 (nth pos l)) (incr pos)))
(t (nth (1- pos) l))))
; lit un entier en de'cimal
(de :readnumber ()
(let ((x 0))
(while (digitp (nth pos l))
(setq x (+ (* x 10) (- (nth pos l) #/0)))
(incr pos))
x))
; lit une chaine jusqu'au ":" suivant
(de :readstring ()
(let ((liste))
(until (eq (nth pos l) #/:) (newl liste (:readcn)))
(nreverse liste)))
; .Section "Fonctions de ge'ne'ration"
; On utilise trois variables de facon globale:
; - term : le nom du terminal pour lequel on genere tout
; - capas : la aliste des capacites du terminal
; - output-file : le fichier de sortie
; ge'ne`re le code d'une fonction "cursor"
; a` partir d'une chai↑ne termcap
(de :cursor (l)
(let ((lvar '(line col)) (lpar '(col line)) (exp) (char))
(while l
(setq char (nextl l))
(if (neq char #/%)
(newl exp `(tyo ,char))
(setq char (nextl l))
(selectq char
(#/d (newl exp `(tyod ,(nextl lvar) 0)))
(#/2 (newl exp `(tyod ,(nextl lvar) 2)))
(#/3 (newl exp `(tyod ,(nextl lvar) 3)))
(#/. (newl exp `(tyo ,(nextl lvar))))
(#/+ (newl exp
`(tyo (+ ,(nextl l) ,(nextl lvar)))))
(#/>
(newl exp `(if (> ,(car lvar) ,(nextl l))
(incr ,(car lvar) ,(nextl l)))))
(#/r (setq lpar (reverse lpar)))
(#/i (newl exp `(incr line)) (newl exp `(incr col)))
(#/% (newl exp `(tyo #/%)))
(#/n (newl exp `(setq ,(car lvar)
(logxor ,(car lvar) 96))))
(#/B (newl exp `(incr ,(car lvar)
(* 6 (div ,(car lvar) 10)))))
(#/D (newl exp `(decr ,(car lvar)
(* 2 (rem ,(car lvar) 16)))))
(t))))
(:de 'tycursor lpar exp)))
; Ici, on se livre a` une petite optimisation:
; on concate`ne les tyo conse'cutifs
; et on en profite pour renverser la liste.
(de :de (sem par exp)
(let ((l) (ltyo)) ; l: nouvelle exp; ltyo: liste des char a tyo
(while exp
(selectq (caar exp)
(tyo (mapc (lambda (tyo) (newl ltyo tyo))
(reverse (cdr (nextl exp)))))
((incr decr setq) (newl l (nextl exp)))
(t
(when ltyo
(newl l `(tyo ,.ltyo)) (setq ltyo nil))
(newl l (nextl exp)))))
(when ltyo (newl l `(tyo ,.ltyo)))
(terpri)
(with ((lmargin 8))
(prin "(de #:tty:" (string term) ":" sem " " par)
(while l
(terpri) (outpos 4) (prin (nextl l)))
(prin ")"))
(terpri)))
; La me↑me mais sans parame`tre et avec n arguments.
(de :den (sem . exp)
(:de sem () exp))
(de :decapa (sem capa)
(if (assoc capa capas)
(:den sem (:cassoc capa))
(:warning sem)))
(de :set (sem val)
(terpri)
(print "(defvar #:tty:" term ":" sem " " val ")")
(print "(defvar #:tty:" sem " " val ") ; compatibilite' v15"))
(de :warning (sem)
(terpri)
(printerror '#:tty:termcap
(format ()
#- #:system:foreign-language "~S : ne sait pas faire"
#+ #:system:foreign-language "~S : don't know how to"
term)
sem))
(de :cassoc (capa)
`(tyo ,.(cassoc capa capas)))
; .Section "Fonction Principale"
(de :compile (term output-file)
(print "; On cree le fichier virtty a partir de termcap pour : " term)
(let ((names (:tgetent term)) (capas)
(#:system:print-for-read ())) ; on prote`ge le print
(ifn names
(error 'termcap 'ERRVIRTTY term))
(setq term (implode (pname term))
capas (:parse names))
; le cas d'indirection
(while (assoc '#"tc" capas)
(let ((auxterm (cassoc '#"tc" capas)) (aux) (aux2))
(setq aux (:tgetent auxterm))
(ifn aux (error ':compile
#- #:system:foreign-language "Ce terminal est defini par rapport a "
#+ #:system:foreign-language "This terminal is defined in terms of "
(string auxterm)))
(setq aux (:parse aux)
capas (append (remq (assoc '#"tc" capas) capas)
aux))
; pour chaque capacite supprimee, on recopie la liste
(while (setq aux (car (rassq t capas)))
(setq aux2 capas)
(while aux2
(ifn (equal (caar aux2) aux)
(nextl aux2)
(rplac (nextl aux2) nil nil))))))
; on regarde si le terminal sait adresser le curseur
(ifn (assoc '#"cm" capas)
(error ':compile
#- #:system:foreign-language "Terminal ringard : pas d'adressage curseur"
#+ #:system:foreign-language "Terminal lacks capability: cursor addressing"
term))
; on regarde si le terminal sait effacer l'ecran
(ifn (or (assoc '#"cd" capas) (assoc '#"cl" capas))
(error ':compile
#- #:system:foreign-language "Terminal ringard : pas d'effacement de l'ecran"
#+ #:system:foreign-language "Terminal lacks capability: clear screen"
term))
; On commence la generation
(with ((outchan (openo output-file)))
; Une petite banniere
(print "; Le←Lisp version 15.2 :"
#- #:system:foreign-language
" compilation du terminal virtuel : "
#+ #:system:foreign-language
" compilation of virtual terminal: "
term)
; Le nom du systeme
(terpri)
(print "(setq #:sys-package:tty '#:tty:" term ")")
; Les variables donnant le nombre de lignes et de colonnes
(if (assoc '#"co" capas)
(:set 'xmax (1- (cassoc '#"co" capas)))
(:set 'xmax 79))
(if (assoc '#"li" capas)
(:set 'ymax (1- (cassoc '#"li" capas)))
(:set 'ymax 23))
(:cursor (cassoc '#"cm" capas))
; S'il existe une visible bell, on redefinit bell
(if (assoc '#"vb" capas)
(:decapa 'tybeep '#"vb"))
; Effacement de l'ecran
(if (assoc '#"cl" capas)
(:decapa 'tycls '#"cl")
(:den 'tycls
(:cassoc '#"cd")
`(tycursor 0 0)))
; Effacement jusqu'a la fin de ligne
(:decapa 'tycleol '#"ce")
; Effacement de la fin de l'ecran
(:decapa 'tycleos '#"cd")
; Effacement du caractere
(if (assoc '#"dc" capas)
(:den 'tydelch
(:cassoc '#"ed")
(:cassoc '#"dc")
(:cassoc '#"dm"))
(:warning 'tydelch))
; Insertion d'une ligne
(:decapa 'tyinsln '#"al")
; Effacement de la ligne
(:decapa 'tydelln '#"dl")
; L'attribut soulignage ou inverse video
(when (and (assoc '#"so" capas) (assoc '#"se" capas))
(:de 'tyattrib '(x)
(list `(if x (tyo ,.(cassoc '#"so" capas))
(tyo ,.(cassoc '#"se" capas)))))
(:set 'tyattrib ()))
(when (and (assoc '#"us" capas) (assoc '#"ue" capas))
(:de 'tyattrib '(x)
(list `(if x (tyo ,.(cassoc '#"us" capas))
(tyo ,.(cassoc '#"ue" capas)))))
(:set 'tyattrib ()))
; Pour inserer un caractere ou une chaine
(if (or (assoc '#"ic" capas)
(assoc '#"im" capas)
(assoc '#"ei" capas))
(:de 'tyinsch '(arg)
(list
(:cassoc '#"ei")
`(tyo arg)
(:cassoc '#"ic")
(:cassoc '#"im")))
(:warning 'tyinsch))
; La chaine d'initialisation
; La caracteristique if de termcap
(let ((aux (cassoc '#"if" capas)) (l))
(when aux
(with ((inchan (openi (string aux))))
(untilexit eof (newl l (readcn)))))
(:den 'typrologue
`(,(symbol (symbol 'tty term) 'tycls))
`(tyo ,.(nreverse l))
(:cassoc '#"is")))
; Pour l'epilogue, on ramene simplement le curseur
(:den 'tyepilogue
`(tycursor 0 (sub1 ,(symbol (symbol 'tty term) 'ymax))))
; Le curseur cache'/vu
(:set 'tyshowcursor t)
(close (outchan)))
term))