; .EnTete "Le-Lisp (c) version 15.2" " " "Le compilateur Terminfo"
; .EnPied " " "%" " "
; .SuperTitre "Le Compilateur Terminfo"
;
; .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: terminfo.ll,v 4.3 88/04/07 18:26:12 nuyens Exp $"
(unless (>= (version) 15.2)
(error 'load 'erricf 'terminfo))
; Tous les symboles pre'ce'de's de : seront cre'e's
; dans le package TERMINFO.
(defvar #:sys-package:colon 'terminfo)
(add-feature 'terminfo)
; Programme de ge'ne'ration de terminaux virtuels Le←Lisp
; a` partir de la base de donne'es terminfo de UN*X System V.
; Le nom du directory qui contient cette base de donne'e
; doit se trouver dans la variable #:system:terminfo-directory
; ou dans la variable shell TERMINFO.
; 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 TERMINFO"
(de :read-entry (term)
(let ((ti (or (getenv "TERMINFO") #:system:terminfo-directory)))
(setq ti (string ti))
(let ((:entry (catenate ti
(ifn (eq (sref ti (1- (slength ti))) #//) "/")
(ascii (sref term 0))
"/"
term)))
(ifn (probefile :entry)
(error 'terminfo 'ERRVIRTTY term))
(with ((inchan (openib :entry)))
(:read-header)
(:skip :sname)
(:read-bools)
(:skip (logand (+ :sname :sbool) 1))
(:read-numbs)
(:read-strgs)
(:read-table)
(close (inchan))))))
; .Section "Les constantes de TERMINFO"
; Il faut mettre a jour cette table apre`s chaque modification
; de terminfo (4) comme l'ajout d'une capacite'.
(defvar :magic-number #8r432) ; nombre magique de terminfo
(defvar :size-of-boolean-section 21); taille de la section des boole'ens
(defvar :size-of-number-section 8); taille de la section des nombres
(defvar :size-of-string-section 145); taille de la section des chai↑nes
; les index des entre'es (avec le nom ANSI)
; en commentaire le nom de la capacite' et l'icode
; (voir terminfo (4))
; les drapeaux
; les nombres
(defvar :columns 0) ; cols co
(defvar :lines 2) ; lines li
; les chai↑nes
(defvar :clear←screen 5) ; clear cl
(defvar :clr←eol 6) ; el ce
(defvar :clr←eos 7) ; ed cd
(defvar :cursor←address 10) ; cup cm
(defvar :cursor←invisible 13) ; civis vi
(defvar :cursor←normal 16) ; cnorm ve
(defvar :delete←char 21) ; dch1 dc
(defvar :delete←line 22) ; dl1 dl
(defvar :enter←delete←mode 29) ; smdc dm
(defvar :enter←insert←mode 31) ; smir im
(defvar :enter←standout←mode 35); smso so
(defvar :enter←underline←mode 36); smul us
(defvar :exit←delete←mode 41) ; rmdc ed
(defvar :exit←insert←mode 42) ; rmir ei
(defvar :exit←standout←mode 43) ; rmso se
(defvar :exit←underline←mode 44); rmul ue
(defvar :flash←screen 45) ; flash vb
(defvar :init←1string 48) ; is1 i1
(defvar :init←2string 49) ; is2 i2
(defvar :init←3string 50) ; is3 i3
(defvar :init←file 51) ; if if
(defvar :insert←character 52) ; ich1 ic
(defvar :insert←line 53) ; il1 al
(defvar :init←prog 138) ; iprog iP
; .Section "Les fonctions de lecture"
; lecture d'un nombre sur 16 bits dans l'ordre Vax/Pdp11
(de :read-short ()
(logor (logand (readcn) 255) (logshift (readcn) 8)))
; saute n octets
(de :skip (n) (repeat n (readcn)))
; lecture de l'en-te↑te (voir terminfo (4))
(de :read-header ()
(ifn (eq (:read-short) :magic-number)
(error 'terminfo 'erroob :entry))
(setq :sname (:read-short)
:sbool (:read-short)
:snumb (:read-short)
:sstrg (:read-short)
:stable (:read-short))
(ifn (eq :sbool :size-of-boolean-section)
(:warning
#- #:system:foreign-language
"la taille de la zone booleenne ne correspond pas"
#+ #:system:foreign-language
"the boolean zone doesn't fit"
))
(setq :bools (makevector :sbool ()))
(ifn (eq :snumb :size-of-number-section)
(:warning
#- #:system:foreign-language
"la taille de la zone des nombres ne correspond pas"
#+ #:system:foreign-language
"the number zone doesn't fit"
))
(setq :numbs (makevector :snumb ()))
(ifn (eq :sstrg :size-of-string-section)
(:warning
#- #:system:foreign-language
"la taille de la zone des chaines ne correspond pas"
#+ #:system:foreign-language
"the string zone doesn't fit"
))
(setq :strgs (makevector :sstrg ()))
(setq :table (makestring :stable 0)))
; lit les drapeaux (un octet 0 ou 1)
(de :read-bools ()
(for (i 0 1 (1- :sbool))
(vset :bools i (eq (readcn) 1))))
; lit les parame`tres nume'riques
(de :read-numbs ()
(for (i 0 1 (1- :snumb))
(let ((n (:read-short)))
(vset :numbs i (if (eq n -1) () n)))))
; lit les param`tres chai↑nes (de'placement dans la table)
(de :read-strgs ()
(for (i 0 1 (1- :sstrg))
(let ((n (:read-short)))
(vset :strgs i (if (eq n -1) () n)))))
; lit la table des chai↑nes
(de :read-table ()
(for (i 0 1 (1- :stable))
(sset :table i (readcn))))
; .Section "Fonctions de ge'ne'ration"
; ge'ne`re le code d'une fonction "cursor"
; a` partir d'une chai↑ne terminfo
(de :cursor (l)
(let ((par1 'line)(par2 'col)(stack)(c)(exp)(special-tyod)(ifl)
(var (makevector 26 ()))(istack)(ifsl))
(while l
(nextl l c)
(if (neq c #/%)
(newl exp `(tyo ,c))
(nextl l c)
(selectq c
(#/% (newl exp `(tyo #/%)))
(#/d (newl exp `(tyod ,(nextl stack) 0)))
(#/2 (ifn (eq (nextl l) #/d)
(error 'terminfo 'errbpa 'cursor))
(setq special-tyod t)
(newl exp `(:tyod ,(nextl stack) 2)))
(#/3 (ifn (eq (nextl l) #/d)
(error 'terminfo 'errbpa 'cursor))
(setq special-tyod t)
(newl exp `(:tyod ,(nextl stack) 3)))
(#/0 (nextl l c)
(if (and (memq c '(#/2 #/3)) (eq (nextl l) #/d))
(newl exp
`(tyod ,(nextl stack) ,(sub c #/0)))
(error 'terminfo 'errbpa 'cursor)))
((#/c #/s) (newl exp `(tyo ,(nextl stack))))
(#/p (selectq (nextl l)
(#/1 (newl stack par1))
(#/2 (newl stack par2))
(#/3 (newl stack par3))
(#/4 (newl stack par4))
(#/5 (newl stack par5))
(#/6 (newl stack par6))
(#/7 (newl stack par7))
(#/8 (newl stack par8))
(#/9 (newl stack par9))
(t (error 'terminfo 'errbpa 'cursor))))
(#/P (nextl l c)
(ifn (and (>= c #/a) (<= c #/z))
(error 'terminfo 'errbpa 'cursor)
(vset var (- c #/a) (nextl stack))))
(#/g (nextl l c)
(ifn (and (>= c #/a) (<= c #/z))
(error 'terminfo 'errbpa 'cursor)
(newl stack (vref var (- c #/a)))))
(#/+ (newl stack `(add ,(nextl stack) ,(nextl stack))))
(#/- (newl stack
(reverse `(,(nextl stack) ,(nextl stack) sub))))
(#/* (newl stack `(mul ,(nextl stack) ,(nextl stack))))
(#// (newl stack
(reverse `(,(nextl stack) ,(nextl stack) div))))
(#/m (newl stack
(reverse `(,(nextl stack) ,(nextl stack) rem))))
(#/& (newl stack `(logand ,(nextl stack) ,(nextl stack))))
(#/| (newl stack `(logor ,(nextl stack) ,(nextl stack))));|
;)
(#/= (newl stack `(= ,(nextl stack) ,(nextl stack))))
(#/> (newl stack `(< ,(nextl stack) ,(nextl stack))))
(#/< (newl stack `(> ,(nextl stack) ,(nextl stack))))
(#/! (let ((arg (nextl stack)))
(ifn (and (consp arg) (memq (car arg) '(= < >)))
(setq arg `(<> 0 ,arg)))
(newl stack `(not ,arg))))
(#/~ (newl stack `(lognot ,(nextl stack))))
(#/i (setq par1 `(add1 ,par1) par2 `(add1 ,par2)))
(#/' (newl stack (nextl l))
(ifn (eq (nextl l) #/')
(error 'terminfo 'errbpa 'cursor)))
(#/{ (let (ll c)
(until (eq (setq c (nextl l)) #/}) (newl ll c))
(newl stack (implode (reverse ll)))))
(#/? (newl exp 'if) (setq ifl t))
(#/t (newl exp (nextl stack)) (newl exp 'then)
(setq istack stack))
(#/e (if istack (:save-stack)) (newl exp 'else)
(setq stack istack))
(#/; (if istack (:save-stack))
(newl exp (:cursor-if))
(setq ifl () stack ())
(when ifsl
(for (i 1 1 ifsl)
(newl stack
(symbol 'terminfo (catenate "x" i)))))
(setq ifsl ()))
(t (error 'terminfo 'errbpa 'cursor)))))
(if (or stack ifl) (error 'terminfo 'errbpa 'cursor))
(when special-tyod
(terpri)
(print "(de #:terminfo:tyod (x n)")
(print " (when (or (> n 1) (> x 9))")
(print " (#:terminfo:tyod (div x 10) (sub1 n)))")
(print " (if (eq x 0) (tyo #\sp)")
(print " (tyo (add #/0 (rem x 10)))))"))
(:de 'tycursor '(col line) exp)))
(de :save-stack ()
(if (and ifsl (neq ifsl (length stack)))
(error 'terminfo 'errbpa 'cursor))
(setq ifsl (length stack) stack (reverse stack))
(let (ss)
(for (i 1 1 ifsl)
(newl ss (nextl stack))
(newl ss (symbol 'terminfo (catenate "x" i))))
(newl exp (cons 'setq ss))))
(de :cursor-if ()
(let (else then test elem)
(until (memq (setq elem (nextl exp)) '(else then)) (newl else elem))
(setq else (:compact else))
(if (eq elem 'then)
(setq then else else ())
(until (eq (setq elem (nextl exp)) 'then) (newl then elem))
(setq then (:compact then)))
(until (memq (setq elem (nextl exp)) '(if else)) (newl test elem))
(while test (newl exp (nextl test)))
(nextl exp test)
(ifn (and (consp test) (memq (car test) '(= < > not)))
(setq test `(<> 0 ,test)))
(ifn (eq elem 'else)
(:if test then else)
(newl exp 'else)
(newl exp (:if test then else))
(:cursor-if))))
(de :compact (l)
(if (and (eq (caar l) 'tyo) (eq (caadr l) 'tyo))
(:compact
(cons (cons 'tyo (nconc1 (cdar l) (cadadr l))) (cddr l)))
l))
(de :if (test then else)
(cond
((cdr then)
(cond
((cdr else) `(if ,test ,(newl then 'progn) ,.else))
((null else) `(when ,test ,.then))
(t `(ifn ,test ,@else ,.then))))
((null then) `(unless ,test ,.else))
(t `(if ,test ,@then ,.else))))
; 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
(if (car 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))))
(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 :decaps (sem caps)
(if (vref :strgs caps)
(:den sem (:get-string caps))
(:cant sem)))
(de :cant (sem)
(terpri)
(print "; ** terminfo : " term " : ne sais pas faire : " sem)))
(de :set (sem val)
(terpri)
(print "(defvar #:tty:" term ":" sem " " val ")")
(print "(defvar #:tty:" sem " " val ") ; compatibilite' v15"))
(de :warning (s)
(terpri)
(print "Avertissement : terminfo : " s))
; .Section "Les chai↑nes de commandes"
(de :get-string (n)
(setq n (vref :strgs n))
(if (and (fixp n) (<= 0 n))
(let (liste)
(untilexit :eos
(let ((c (sref :table n)))
(incr n)
(if (and (eq c #/$) (eq (sref :table n) #/<))
(:look-for-delay))
(if (eq c 0) (exit :eos))
(newl liste c)))
(cons 'tyo (reverse liste)))))
; saute les de'lais
(de :look-for-delay ()
(let ((nn n)(cc c))
(incr n) ; saute <
(untilexit :eop
(selectq (sref :table n)
(#/> (setq n (1+ n) c (sref :table n)) (exit :eop))
((#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9 #/* #/.) (incr n))
(t (setq n nn c cc))))))
; .Section "Fonction Principale"
(de :compile (term output-file)
(setq term (implode (pname term)))
(print "; On cree le fichier virtty a partir de terminfo pour : " term)
(:read-entry (string term))
(let (#:system:print-for-read)
; on regarde si le terminal sait adresser le curseur
(ifn (vref :strgs :cursor←address)
(error 'terminfo
#- #: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 (vref :strgs :clear←screen) (vref :strgs :clr←eos))
(error 'terminfo
#- #: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
(when (vref :numbs :columns)
(:set 'xmax (1- (vref :numbs :columns))))
(when (vref :numbs :lines)
(:set 'ymax (1- (vref :numbs :lines))))
; L'adressage du curseur
(:cursor (cdr (:get-string :cursor←address)))
; S'il existe une visible bell, on rede'finit bell
(if (vref :strgs :flash←screen) (:decaps 'tybeep :flash←screen))
; Effacement de l'e'cran
(if (vref :strgs :clear←screen)
(:decaps 'tycls :clear←screen)
(:den 'tycls (:get-string :clr←eos) `(tycursor 0 0)))
; Effacement jusqu'a la fin de ligne
(:decaps 'tycleol :clr←eol)
; Effacement jusqu'a la fin de l'ecran
(:decaps 'tycleos :clr←eos)
; Effacement du caractere
(if (vref :strgs :delete←char)
(:den 'tydelch
(:get-string :exit←delete←mode)
(:get-string :delete←char)
(:get-string :enter←delete←mode))
(:cant 'tydelch))
; Insertion d'une ligne
(:decaps 'tyinsln :insert←line)
; Effacement de la ligne
(:decaps 'tydelln :delete←line)
; L'attribut soulignage ou inverse video
(when (and (vref :strgs :enter←standout←mode)
(vref :strgs :exit←standout←mode))
(:de 'tyattrib '(x)
(list `(if x
,(:get-string :enter←standout←mode)
,(:get-string :exit←standout←mode))))
(:set 'tyattrib ()))
(when (and (vref :strgs :enter←underline←mode)
(vref :strgs :exit←underline←mode))
(:de 'tyattrib '(x)
(list `(if x
,(:get-string :enter←underline←mode)
,(:get-string :exit←underline←mode))))
(:set 'tyattrib ()))
; Pour inserer un caractere ou une chaine
(if (or (vref :strgs :insert←character)
(vref :strgs :enter←insert←mode)
(vref :strgs :exit←insert←mode))
(:de 'tyinsch '(arg)
(list
(:get-string :exit←insert←mode)
`(tyo arg)
(:get-string :insert←character)
(:get-string :enter←insert←mode)))
(:cant 'tyinsch))
; La chaine d'initialisation
; La caracteristique if de terminfo
(let (l)
(if (vref :strgs :init←file)
(with ((inchan
(openib
(string (cdr (:get-string :init←file))))))
(untilexit eof (newl l (readcn)))))
(:den 'typrologue
`(,(symbol (symbol 'tty term) 'tycls))
(:get-string :init←1string)
(:get-string :init←2string)
`(tyo ,.(reverse l))
(if (vref :strgs :init←prog)
`(comline
,(string (cdr (:get-string :init←prog)))))
(:get-string :init←3string)))
; Pour l'epilogue, on ramene simplement le curseur
(:den 'tyepilogue
`(tycursor 0 (1- ,(symbol (symbol 'tty term) 'ymax))))
; Le curseur cache'/vu
(when (and (vref :strgs :cursor←invisible)
(vref :strgs :cursor←normal))
(:de 'tyshowcursor '(x)
(list `(if x
,(:get-string :cursor←normal)
,(:get-string :cursor←invisible)))))
(:set 'tyshowcursor t)
(close (outchan)))
term))