; .EnTete "Le-Lisp (c) version 15.2" " " "L'e'diteur de ligne"
; .EnPied " " "%" " "
; .Chapitre 16 "L'e'diteur de ligne"
;
; .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: edlin.ll,v 4.1 88/01/13 12:19:28 kuczynsk Rel $"
(unless (>= (version) 15.21)
(error 'load 'erricf 'edlin))
(defvar #:sys-package:colon 'edlin)
(add-feature 'edlin)
; .Section "Gestion d'un historique des commandes"
(setq #:sys-package:colon '#:edlin:history)
(defvar :last-string)
(defvar :maxlen 100)
; l'history commence toujours par une chaine vide
; comme ca, il n'y a plus de flag :at-end
(defvar :history '("" "; In principium erat Le←Lisp..."))
(defvar :position :history)
(de :show ()
(terpri 2)
(:show-aux (cdr :history)))
(de :show-aux (history)
; on ne conse pas : on alloue dynamiquement de la pile
(if (null history) 0
(let ((no-line (:show-aux (cdr history))))
(print (incr no-line) " " (car history))
no-line)))
(de :previous ()
(if (cdr :position)
(setq :position (cdr :position))
(tybeep))
(car :position))
(de :next ()
(if (:endp) (tybeep)
(let ((history :history))
(until (eq (cdr history) :position)
(nextl history))
(setq :position history)))
(car :position))
(de :add (str)
(let ((history :history))
(repeat (sub :maxlen 2) (nextl history))
(setq :history
(rplac (if (null (cdr history))
; un nouveau cons
(ncons ())
; on reprend le dernier cons
(prog1 (cdr history) (rplacd history nil)))
; on remet la tete d'history (chaine vide)
(car :history)
; et la chaine a conserver
(rplaca :history str)))))
(de :find (s)
(let ((position :position))
(tag found
(while (cdr :position)
(:previous)
(when (index s (car :position))
(exit found (car :position))))
(tybeep)
(setq :position position)
() )))
(de :last ()
(car (setq :position :history)))
(de :first ()
(car (setq :position (last :history))))
(de :endp ()
(eq :position :history))
; .Section "Utilitaires"
(setq #:sys-package:colon '#:edlin:util)
(defvar :tampon (makestring 256 #\sp))
(de :insert-in-string (string pos max cn)
(if (eq pos max)
(sset string pos cn)
(bltstring :tampon 0 string pos (sub max pos))
(sset string pos cn)
(bltstring string (add1 pos) :tampon 0 (sub max pos))))
(de :delete-in-string (string pos max)
(if (eq pos max)
(sset string pos (sref string (add1 pos)))
(bltstring :tampon 0 string (add1 pos) (sub1 (sub max pos)))
(bltstring string pos :tampon 0 (sub1 (sub max pos)))))
; .Section "Gestion de l'image du tampon d'entre'e"
(setq #:sys-package:colon 'edlin)
(de :image:redisplay ()
(tycr) (tycleol) (tyflush)
(tystring (prompt) (slength (prompt)))
(:image:redisplay-eol 0))
(de :image:redisplay-eol (pos)
(let ((:pos pos))
(:image:tycleol)
(:image:move :max))
(:image:tycleol)
(setq pos :pos)
(let ((:pos :max))
(:image:move pos)))
(de :image:move (x)
(cond ((lt :pos x)
(let ((pos :pos))
(until (eq pos x)
(tyctl tycn (sref :inbuf pos))
(setq pos (add1 pos)))))
((gt :pos x)
(let ((pos :pos))
(until (eq pos x)
(tyctl tybs (sref :inbuf
(setq pos (sub1 pos)))))))))
(de :image:insert (cn)
(if (eq :pos :max)
(tyctl tycn cn)
; on aide les terminaux vt100
(unless (tyctl tyinsch cn)
(:image:redisplay-eol (sub1 :pos)))))
(de :image:delete (cn)
(unless (tyctl tydelcn cn)
(:image:redisplay-eol :pos)))
(de :image:delete-without-redisplay (cn)
(tyctl tydelcn cn))
(de :image:tycleol ()
(unless (tycleol)
; ca marche a peu pres
; dans la mesure ou on traite les caracteres un par un
(tycn #\sp) (tybs #\sp))
(tyflush))
(dmd tyctl (tyfnt x)
`(let ((x ,x))
(when (lt x #\sp)
(,tyfnt #/↑)
(setq x (logor x #$40)))
(,tyfnt x)))
; .Section "Edition de ligne a` la Emacs"
(setq #:sys-package:colon 'edlin)
(defvar :inbuf)
; le kill-buffer est global et conserve entre 2 appels a :bol
(defvar :kill-buffer (copy (inbuf))) ; copie pour wipe & yank
(defvar :kill-length 0) ; longueur du yank
(defvar :max)
(defvar :pos)
; pour attendre la parenthese ouvrante (voir insert-rpar)
(defvar :loop 1000)
(de :bol ()
(if (or (fixp (inchan))
(not #:system:real-terminal-flag)
#:system:line-mode-flag)
(super-itsoft '#.#:sys-package:colon 'bol ())
(let ((:inbuf (inbuf)) ; le tampon de lecture
(:last-string ())
(:pos 0) ; la position courante
(:max 0))
(tystring (prompt) (slength (prompt)))
(unless (:history:endp)
(:do-command #↑N))
(untilexit eoi ; jusqu'a` la fin de l'input
(:work-on (tyi)))
(tynewline)
(inmax :max)
(inpos 0))))
(de :work-on (char)
(if (and (eq :pos 0) (eq :max 0)
(or (eq (typecn char) 'cmacro) (eq (typecn char) 'smacro)))
(:insert char)
(or (:do-command char) (:insert char))))
(de :insert (char)
(:util:insert-in-string :inbuf :pos :max char)
(setq :pos (add1 :pos))
(setq :max (add1 :max))
(:image:insert char)
(when (ge :max (slength :inbuf))
(exit eoi)))
(de :delete (char)
(:util:delete-in-string :inbuf :pos :max)
(setq :max (sub1 :max))
(:image:delete char))
(de :delete-without-redisplay (char)
(:util:delete-in-string :inbuf :pos :max)
(setq :max (sub1 :max))
(:image:delete-without-redisplay char))
(de :move (x)
(:image:move x)
(setq :pos x))
(de :do-command (char)
(block :do-command
(selectq char
(#↑A (:move 0))
(#↑E (:move :max))
(#↑B (when (gt :pos 0)
(:move (sub1 :pos))))
(#↑F (when (lt :pos :max)
(:move (add1 :pos))))
((#\cr #\lf)
(exit eoi (:store-line) (:history:last)))
(#↑O (exit eoi (:store-line)))
((#↑H 127)
(when (gt :pos 0)
(:move (sub1 :pos))
(:delete (sref :inbuf :pos))))
(#↑D (when (lt :pos :max)
(:delete (sref :inbuf :pos))))
(#↑K (setq :last-string ())
(:delete-end-of-line))
((#↑X #↑U) (setq :last-string ())
(:delete-begining-of-line))
(#↑Y (:insert-substring :kill-buffer :kill-length))
(#↑I (:replace-string (:history:previous)))
(#↑N (:replace-string (:history:next)))
(#↑T
(when (gt :pos 1)
(let ((char1 (sref :inbuf (sub :pos 2)))
(char2 (sref :inbuf (sub :pos 1))))
(:move (sub :pos 2))
(:delete char1) (:delete char2)
(:insert char2) (:insert char1))))
(#↑L (:redisplay))
(#/\ (:insert (tyi)))
(#\esc (:do-esc-command (tyi)))
(#|(|# #/) (:insert-rpar))
(t (return-from :do-command ())))
t ))
(de :do-esc-command (char)
(block :do-esc-command
(selectq char
(#"0123456789"
(let ((count (sub char #/0)))
(while (memq (setq char (tyi)) '#"0123456789")
(setq count (add (sub char #/0) (mul count 10))))
(repeat count (:work-on char))))
(#/?
(terpri)
(with ((inchan (openi (catenate #:system:llib-directory
"edhelp"
#:system:lelisp-extension))))
(untilexit eof (print (readstring))))
(terpri)
(:redisplay))
(#/b (:backword #↑B))
(#/f (:forword #↑F))
((#↑H #\del) (:backword #↑H))
(#/h (:history:show)
(:redisplay))
((#/d #↑D) (:forword #↑D))
(#↑G (tybeep))
(#/< (:replace-string (:history:first)))
(#/> (:replace-string (:history:last)))
(#\esc
(let ((s (:history:find
; :last-string est remis a () dans bol et ↑U
(or :last-string
(setq :last-string
(substring :inbuf 0 :max))))))
(when s (:replace-string s))))
(#\sp (:find-in-oblist :pos))
(#/' (let ((pos :pos))
(:backword #↑B)
(:insert #/')
(repeat (sub (add1 pos) :pos) (:do-command #↑F))))
(#/( #|)|# (:move (:backwardparen :pos)))
(t (tybeep) (return-from :do-esc-command ())))
t ))
(de :find-in-oblist (pos)
(:backword #↑B)
(let ((l (sub pos :pos))
(s (:search-in-oblist :pos
(substring :inbuf :pos (sub pos :pos)))))
(repeat l (:do-command #↑F))
(cond ((atom s) (tybeep))
((null (cdr s))
(setq s (string (car s)))
(for (i l 1 (sub1 (slength s)))
(:insert (sref s i))))
(t (terpri)
(mapc 'print (setq s (sort 'alphalessp s)))
(terpri)
(setq s (:comm-string s))
(:redisplay)
(for (i l 1 (sub1 (slength s)))
(:insert (sref s i)))))))
(de :store-line ()
(when (gt :max 0)
; allocation et stockage d'une nouvelle string
(:history:add (substring :inbuf 0 :max)))
(sset :inbuf :max #\cr) (setq :max (add1 :max))
(sset :inbuf :max #\lf) (setq :max (add1 :max)))
(de :delete-end-of-line ()
(bltstring :kill-buffer 0 :inbuf :pos (sub :max :pos))
(setq :kill-length (sub :max :pos))
(repeat (sub :max :pos)
(when (lt :pos :max)
(:delete-without-redisplay (sref :inbuf :pos))))
(:image:redisplay-eol :pos))
(de :delete-begining-of-line ()
(bltstring :kill-buffer 0 :inbuf 0 :pos)
(setq :kill-length :pos)
(repeat :pos (when (gt :pos 0)
(:move (sub1 :pos))
(:delete-without-redisplay (sref :inbuf :pos))))
(:image:redisplay-eol :pos))
(de :insert-substring (s l)
(for (i 0 1 (sub1 (imin l (slength s))))
(:insert (sref s i))))
(de :replace-string (s)
(let ((l (slength s)))
(bltstring :inbuf 0 s 0 l)
(setq :max l :pos :max))
(:redisplay))
(de :alphap (char)
(eq (typecn char) 'cpname))
(de :backword (com)
(until (or (eq :pos 0) (:alphap (sref :inbuf (sub1 :pos))))
(:do-command com))
(while (and (gt :pos 0) (:alphap (sref :inbuf (sub1 :pos))))
(:do-command com)))
(de :forword (com)
(until (or (eq :pos :max) (:alphap (sref :inbuf :pos)))
(:do-command com))
(while (and (lt :pos :max) (:alphap (sref :inbuf :pos)))
(:do-command com)))
(de :redisplay ()
(:image:redisplay))
(de :search-in-oblist (pos string)
(let (pkgc (npos pos))
(while (and (gt npos 0)
(or (memq (chrnth (sub1 npos) :inbuf) '#":#")
(:alphap (chrnth (sub1 npos) :inbuf))))
(setq npos (sub1 npos)))
(setq pkgc
(car (catcherror ()
(implode (explode (substring :inbuf
npos (sub (sub1 pos) npos)))))))
(maploblist
(lambda (u)
(when (and (eq pkgc (packagecell u))
(eq 0 (index string (string u) 0)))
(ncons u))))))
(de :comm-string (lsymb)
; lsymb est trie'e par ordre alphabetique
(let ((s1 (string (car lsymb)))
(s2 (string (car (last lsymb)))))
(let ((i 0) (fin (imin (slength s1) (slength s2))))
(while (and (lt i fin) (eq (sref s1 i) (sref s2 i)))
(setq i (add1 i)))
(substring s1 0 i))))
(de :insert-rpar ()
(:insert #|(|# #/))
(:move (prog1 :pos (:move (:backwardparen :pos)) (tyflush)
(repeat :loop (setq :pos :pos)))))
(de :backwardparen (pos)
(let ((depth 1))
(when (gt pos 0)
(decr pos 1)
(while (and (gt pos 0)
(or (neq 'clpar (typecn (sref :inbuf pos)))
(gt (decr depth 1) 0)))
(decr pos)
(or (neq 'crpar (typecn (sref :inbuf pos)))
(setq depth (add1 depth))))))
pos )
; .Section "Les Fonctions Utilisateur"
(de edlin ()
(unless (memq '#.#:sys-package:colon #:sys-package:itsoft)
(setq #:sys-package:itsoft
(cons '#.#:sys-package:colon #:sys-package:itsoft))))
(de edlinend ()
(setq #:sys-package:itsoft
(delq '#.#:sys-package:colon #:sys-package:itsoft)))