Commit d1e96efc authored by Pascal J. Bourguignon's avatar Pascal J. Bourguignon

Corrected bug in GOTO that poped loops at the wrong time.

parent 2e0f2c27
-*- mode:org; coding:utf-8 -*-
* TODO: 00003 FAIRE n POUR I_1 JUSQUA 100 doesn't work.
* DONE TODO: 00003 FAIRE n POUR I_1 JUSQUA 100 doesn't work.
CLOSED: [2014-05-13 Tue 04:11]
- State "DONE" from "" [2014-05-13 Tue 04:11] \\
Corrected bug in GOTO that would pop loops at the wrong time.
#+BEGIN_SRC(lse)
1 FAIRE 10 POUR I_1 JUSQUA 100
......
......@@ -53,7 +53,6 @@
auto-mode-alist))
(defgroup lse nil
"Major mode for editing L.S.E. code."
:prefix "lse-"
......
-0.09899583
\ No newline at end of file
-0.11599586
\ No newline at end of file
......@@ -154,7 +154,7 @@ BONJOUR ~8A
:unicode-halfwidth
:ascii)
:terminal terminal))
(*trace-output* (make-broadcast-stream)))
#-(and) (*trace-output* (make-broadcast-stream)))
(setf *task* task) ; to help debugging, we keep the task in the global binding.
(or (parse-options (or args (arguments)) nil nil nil)
;; parse-option may call show-bindings which calls
......
......@@ -1669,7 +1669,7 @@ Voir les commandes TABLE DES FICHIERS, SUPPRIMER."
;; We provide a REPL for LE (repl) command for debugging.
#+developing
#+debugging
(defmacro handling-errors (&body body)
`(HANDLER-CASE (progn ,@body)
(simple-condition
......@@ -1684,7 +1684,7 @@ Voir les commandes TABLE DES FICHIERS, SUPPRIMER."
(io-format *task* "~&~A: ~% ~S~%"
(class-name (class-of err)) err))))
#+developing
#+debugging
(defun repl ()
(do ((+eof+ (gensym))
(hist 1 (1+ hist)))
......@@ -1700,7 +1700,7 @@ Voir les commandes TABLE DES FICHIERS, SUPPRIMER."
(io-format *task* "~& --> ~{~S~^ ;~% ~}~%" /))))
#+developing
#+debugging
(defcommand "LE EVALUER UNE EXPRESSION LISP" awake une-ligne (ligne)
"Commande de déboguage: évaluation d'une expression LISP."
(io-new-line *task*)
......@@ -1717,7 +1717,7 @@ Voir les commandes TABLE DES FICHIERS, SUPPRIMER."
(setf results nil))))))
(io-format *task* "~%~A~%~@[=> ~{~S~%~^ ~}~]" output results)))
#+developing
#+debugging
(defcommand "LD DESASSEMBLER A PARTIR DE" awake deux-numeros-optionels (from to)
"Commande de deboguage: Désassemble les lignes de programme."
(io-new-line *task*)
......@@ -1733,7 +1733,7 @@ Voir les commandes TABLE DES FICHIERS, SUPPRIMER."
(vm-code-vectors (task-vm *task*)))
(io-format *task* "~:{~*~A~%~A~%~}" (sort lines '< :key (function first)))))
#+developing
#+debugging
(defcommand "LP DEASSEMBLER/PERFORER A PARTIR DE" awake deux-numeros-optionels (from to)
"Commande de deboguage: Désassemble les lignes de programme en perforant un ruban."
(io-new-line *task*)
......@@ -1744,7 +1744,7 @@ Voir les commandes TABLE DES FICHIERS, SUPPRIMER."
(io-format *task* "~%PERFORATION EFFECTUEE.~%"))
#+developing
#+debugging
(defcommand "SHOW BINDINGS" awake nil ()
"Montre les touches."
(let ((terminal (task-terminal *task*)))
......@@ -1761,7 +1761,7 @@ Voir les commandes TABLE DES FICHIERS, SUPPRIMER."
(terminal-keysym-label terminal :attention)
(terminal-keysym-label terminal :return))))
#+developing
#+debugging
(defun initialize-debugging-task ()
(setf *command-group* awake
*task* (make-instance 'task
......@@ -1847,7 +1847,7 @@ Voir les commandes TABLE DES FICHIERS, SUPPRIMER."
#|else empty line, just ignore it.|#)))
(defvar *debug-repl* nil)
(defvar *debug-repl* #+debugging t #-debugging nil)
;; (setf *debug-repl* nil)
;; (setf *debug-repl* t)
......@@ -1906,7 +1906,7 @@ Voir les commandes TABLE DES FICHIERS, SUPPRIMER."
(io-format task "~%PRET~%")
(io-finish-output task))
(user-interrupt (condition)
;; #+developing (io-format task "~%-Condition: ~A~%" condition)
#+debugging (io-format task "~%-Condition: ~A~%" condition)
(io-format task " ")
(io-standard-redirection task)
(echo)
......
1* COMPTE UNE MINUTE, DE 1 A 6O
10 FAIRE 50 POUR I_1 JUSQUA 60
20 AFFICHER[C,20X,C,U]I
30 T_TEM()
40 SI T=TEM() ALORS ALLER EN 40
50* FIN FAIRE
60 TERMINER
1* COMPTE DE 1 A 100
10 I_1
15 SI I=100 ALORS ALLER EN 45
20 AFFICHER[C,20X,C,U]I
25 T_TEM()
30 SI T=TEM() ALORS ALLER EN 30
35 AFFICHER['.']
40 I_I+1;ALLER EN 15
45 TERMINER
......@@ -510,7 +510,7 @@ Résultat le OU exclusif bit-à-bit entre les bits de A et ceux de B."
#+developing
#+debugging
(defunction (lisp-eval "LISP") (expr &optional (print 0) (noerr 0))
"Evaluation d'une expression LISP"
"LISP(EXPR,PRINT,NOERR)
......
......@@ -64,7 +64,9 @@
(defparameter *program-name* "lse")
(defparameter *program-system* :com.informatimago.lse.cli)
(pushnew :developing *features*)
;; (pushnew :lse-scanner-debug *features*)
(pushnew :debugging *features*)
(pushnew :lse-case-insensitive *features*)
(pushnew :lse-unix *features*)
(pushnew :lse-extensions *features*)
......@@ -78,8 +80,7 @@
#+windows (mapc 'delete-file (directory dir))
#-windows (asdf:run-shell-command "rm -rf ~S" (namestring dir)))
(ql:quickload :swank)
;; #+debugging (ql:quickload :swank) ;; cannot load swank since cli.lisp will switch to swank-terminal.
(ql:quickload *program-system*)
......@@ -108,10 +109,10 @@
(setf ccl:*backtrace-print-level* nil)
(test/fonctions :silence t)
(setf *debug-vm* '(:error)
*debug-repl* t)
(setf *debug-vm* '()
*debug-repl* nil)
#+debugging (setf *debug-vm* '(:error)
*debug-repl* t)
#-debugging (setf *debug-vm* '()
*debug-repl* nil)
......
......@@ -59,7 +59,7 @@
(defparameter *program-name* "lse")
(defparameter *program-system* :com.informatimago.lse.cli)
(pushnew :developing *features*)
(pushnew :debugging *features*)
(pushnew :lse-case-insensitive *features*)
(pushnew :lse-unix *features*)
(pushnew :lse-extensions *features*)
......
......@@ -59,7 +59,7 @@
(defparameter *program-name* "lse-server")
(defparameter *program-system* :com.informatimago.lse.server)
(pushnew :developing *features*)
(pushnew :debugging *features*)
(pushnew :lse-case-insensitive *features*)
(pushnew :lse-unix *features*)
(pushnew :lse-extensions *features*)
......@@ -95,11 +95,10 @@
(setf ccl:*backtrace-print-level* nil)
(test/fonctions :silence t)
(setf *debug-vm* t
*debug-repl* t)
(setf *debug-vm* nil
*debug-repl* nil)
#+debugging (setf *debug-vm* '(:error)
*debug-repl* t)
#-debugging (setf *debug-vm* '()
*debug-repl* nil)
;;;---------------------------------------------------------------------
......
This diff is collapsed.
......@@ -64,7 +64,7 @@ This package exports iolib utilities, functions to make handlers.
"The current socket")
#+developing
#+debugging
(defvar *backtrace* nil)
......@@ -83,7 +83,7 @@ Run the event dispatch loop.
(progn
;; let ((iolib.multiplex::*minimum-event-loop-step* 0.0d0)
;; (iolib.multiplex::*maximum-event-loop-step* nil))
#+developing
#+debugging
(handler-bind
((condition (lambda (condi)
(invoke-debugger condi)
......
......@@ -76,7 +76,9 @@
;; (quick-reload :com.informatimago.rdp)
(pushnew :developing *features*)
;; (setf *features* (set-difference *features* '(:lse-scanner-debug :lse-input-debug)))
;; (pushnew :lse-scanner-debug *features*)
(pushnew :debugging *features*)
(pushnew :lse-case-insensitive *features*)
(pushnew :lse-unix *features*)
(pushnew :lse-extensions *features*)
......
......@@ -38,8 +38,7 @@
;;;;****************************************************************************
(in-package "COM.INFORMATIMAGO.LSE")
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :lse-scanner-debug *features*))
;;----------------------------------------------------------------------
;; tokens
;;----------------------------------------------------------------------
......@@ -358,8 +357,8 @@
:non-terminal-stack (copy-list *non-terminal-stack*)
:expected-token token
:format-control
#+developing "ATTENDU ~S, PAS ~:[~A ~S~;FIN DE LIGNE~2*~]~%PILE NON TERMINAUX: ~A~%PRODUCTION: ~{~A --> ~A~}"
#-developing "ATTENDU ~S, PAS ~:[~A ~S~;FIN DE LIGNE~2*~]"
#+debugging "ATTENDU ~S, PAS ~:[~A ~S~;FIN DE LIGNE~2*~]~%PILE NON TERMINAUX: ~A~%PRODUCTION: ~{~A --> ~A~}"
#-debugging "ATTENDU ~S, PAS ~:[~A ~S~;FIN DE LIGNE~2*~]"
:format-arguments
(list
(token-kind-label (token-kind token))
......@@ -477,8 +476,9 @@ TRANSITION: (state-name (string-expr body-expr...)...) ...
base-case)))))
`(symbol-macrolet ,(generate-state-values transitions)
(loop
#+lse-scanner-debug (print (list 'state '= ,statevar 'code '= ,codevar (format nil "~S" (code-char ,codevar))))
#+lse-scanner-debug (finish-output)
#+lse-scanner-debug (progn
(print (list 'state '= ,statevar 'code '= ,codevar (format nil "~S" (code-char ,codevar))))
(terpri) (finish-output))
(ecase ,statevar
,@(let ((state-value -1))
(mapcar
......@@ -615,8 +615,7 @@ TRANSITION: (state-name (string-expr body-expr...)...) ...
:format-arguments args
:buffer (copy-seq (scanner-buffer scanner))))
(invalid-character (ch &optional (format-control "") &rest format-arguments)
#+lse-scanner-debug (print `(invalid-character ,ch ,(scanner-buffer scanner) ,format-control ,@format-arguments))
#+lse-scanner-debug (finish-output)
#+lse-scanner-debug (progn (print `(invalid-character ,ch ,(scanner-buffer scanner) ,format-control ,@format-arguments)) (terpri) (finish-output))
(error 'lse-scanner-error-invalid-character
:line (scanner-line scanner)
:column (setf (scanner-column scanner) index)
......@@ -632,8 +631,7 @@ TRANSITION: (state-name (string-expr body-expr...)...) ...
format-control format-arguments)
:buffer (copy-seq (scanner-buffer scanner))))
(skip ()
#+lse-scanner-debug (print `(skip))
#+lse-scanner-debug (finish-output)
#+lse-scanner-debug (progn (print `(skip)) (terpri) (finish-output))
(if (< (incf index) buflen)
(setf code (char-code (aref buffer index)))
(return-from scan-lse-token
......@@ -641,23 +639,19 @@ TRANSITION: (state-name (string-expr body-expr...)...) ...
(scanner-column scanner) index
(scanner-current-token scanner) (make-eol scanner)))))
(start ()
#+lse-scanner-debug (print `(start))
#+lse-scanner-debug (finish-output)
#+lse-scanner-debug (progn (print `(start)) (terpri) (finish-output))
(setf start index))
(produce (token)
#+lse-scanner-debug (print `(produce ,token))
#+lse-scanner-debug (finish-output)
#+lse-scanner-debug (progn (print `(produce ,token)) (finish-output))
(return-from scan-lse-token
(setf (scanner-state scanner) state
(scanner-column scanner) index
(scanner-current-token scanner) token)))
(shift (new-state)
#+lse-scanner-debug (print `(shift ,new-state))
#+lse-scanner-debug (finish-output)
#+lse-scanner-debug (progn (print `(shift ,new-state)) (terpri) (finish-output))
(setf state new-state))
(motcle ()
#+lse-scanner-debug (print `(motcle))
#+lse-scanner-debug (finish-output)
#+lse-scanner-debug (progn (print `(motcle)) (terpri) (finish-output))
(let* ((text (subseq buffer start index))
(entry (rassoc text (if (= state +in-format+)
*tokens+format-specifiers*
......@@ -666,20 +660,20 @@ TRANSITION: (state-name (string-expr body-expr...)...) ...
(function string-equal)
(function string=)))))
(when entry
#+lse-scanner-debug (print `(motcle ,(car entry) ,text))
#+lse-scanner-debug (finish-output)
#+lse-scanner-debug (progn (print `(motcle ,(car entry) ,text)) (terpri) (finish-output))
(make-instance 'tok-motcle
:kind (car entry)
:text text
:line (scanner-line scanner)
:column (scanner-column scanner)))))
(token (tok)
#+lse-scanner-debug (print `(tok ,tok ,(if (member tok '(tok-litchaine tok-commentaire))
(subseq buffer start index)
(if (task-case-insensitive *task*)
(string-upcase (subseq buffer start index))
(subseq buffer start index)))))
#+lse-scanner-debug (finish-output)
#+lse-scanner-debug (progn
(print `(tok ,tok ,(if (member tok '(tok-litchaine tok-commentaire))
(subseq buffer start index)
(if (task-case-insensitive *task*)
(string-upcase (subseq buffer start index))
(subseq buffer start index)))))
(terpri) (finish-output))
(make-instance tok
:kind tok
:text (if (member tok '(tok-litchaine tok-commentaire))
......@@ -690,13 +684,15 @@ TRANSITION: (state-name (string-expr body-expr...)...) ...
:line (scanner-line scanner)
:column start)))
(macrolet ((advance (token &rest args)
#+lse-scanner-debug `(progn (print `(advance ,',token ,',args))
(finish-output)
(if (< (incf index) buflen)
(setf code (char-code (aref buffer index)))
,(if (eq token :error-on-eof)
`(scan-error ,@args)
`(produce ,token))))
#+lse-scanner-debug `(progn
(print `(advance ,',token ,',args))
(terpri)
(finish-output)
(if (< (incf index) buflen)
(setf code (char-code (aref buffer index)))
,(if (eq token :error-on-eof)
`(scan-error ,@args)
`(produce ,token))))
#-lse-scanner-debug
`(if (< (incf index) buflen)
(setf code (char-code (aref buffer index)))
......
1.0.0--0.099-CCL-DARWIN
\ No newline at end of file
1.0.0--0.113-CCL-DARWIN
\ No newline at end of file
1.0.0--0.099-CCL-DARWIN, compiled 2014-05-11 04:43:31 on larissa.home
\ No newline at end of file
1.0.0--0.113-CCL-DARWIN, compiled 2014-05-12 01:07:42 on larissa.home
\ No newline at end of file
1.0.0--0.099
\ No newline at end of file
1.0.0--0.113
\ No newline at end of file
......@@ -111,6 +111,7 @@
"TERMINAL-CARRIAGE-RETURN" "TERMINAL-LINE-FEED" "TERMINAL-NEW-LINE"
"TERMINAL-WRITE-STRING" "TERMINAL-FINISH-OUTPUT"
"TERMINAL-YIELD"
"TERMINAL-SKIP-CHARACTERS" "TERMINAL-READ-BUFFERED-CHARACTER"
"STANDARD-TERMINAL"
"INPUT-STREAM" "OUTPUT-STREAM"
......@@ -124,7 +125,6 @@
"IO-NEW-LINE" "IO-FINISH-OUTPUT"
"IO-READ-LINE" "IO-READ-STRING" "IO-READ-NUMBER"
"IO-ECHO" "IO-FORMAT"
"IO-SKIP-CHARACTERS" "IO-READ-BUFFERED-CHARACTER"
"*DECTECH-LEFTWARDS-ARROW*"
"*DECTECH-UPWARDS-ARROW*"
"*UNICODE-LEFTWARDS-ARROW*"
......
......@@ -83,14 +83,14 @@
(cd #P "/home/pjb/src/pjb/nasium-lse/src/")
(pushnew #P"/home/pjb/src/pjb/nasium-lse/dependencies/zebu-3.5.5-pjb/" asdf:*central-registry*)
(pushnew #P "/home/pjb/src/pjb/nasium-lse/src/" asdf:*central-registry*)
(pushnew :developing *features*)
(pushnew :debugging *features*)
;;----------------------------------------------------------------------
(in-package :cl-user)
(cd #P "/home/pjb/src/pjb/nasium-lse/src/")
(pushnew #P "/home/pjb/src/pjb/nasium-lse/src/" asdf:*central-registry*)
(pushnew #P "/home/pjb/src/public/rdp/" asdf:*central-registry*)
(pushnew :developing *features*)
(pushnew :debugging *features*)
(setf *print-right-margin* 200
*print-pretty* t
*print-case* :downcase)
......@@ -110,7 +110,7 @@
(in-package :cl-user)
(cd #P "/home/pjb/src/pjb/nasium-lse/src/")
(pushnew #P "/home/pjb/src/pjb/nasium-lse/src/" asdf:*central-registry*)
(pushnew :developing *features*)
(pushnew :debugging *features*)
(ql:quickload :com.informatimago.lse :verbose t :explain t)
(in-package :com.informatimago.lse)
......
......@@ -51,3 +51,116 @@ Now the problem is that reading can be buffered already, so we may get a (unfini
Interrupts (ESC, C-a) are processed by the low level I/O.
"
;; Le thread principal peut lire directement le ruban,
;; mais pour le terminal, il doit prendre les caracteres dans tampon_entree,
;; et attendre sur le thread terminal.
;;
;; Le thread terminal lit chaque caractere venant du terminal et
;; les aiguille :
;; - interuption (ESC),
;; - signal (CTRL-A),
;; - tampon_entree lorsque le thread principal attend une entrée terminal,
;; - /dev/null lorsque le thread principal n'attend pas d'entrée terminal,
;; - echo sur le terminal lorsqu'on est pas en mode SILENCE.
;; - fin de l'entrée et signal du thread principal sur terminateur.
;;
;; On va faire lire le ruban par le thread terminal. Il fera un poll
;; (on pourrait avoir plus de 32 descripteurs ouverts en même temps
;; avec 16 consoles+rubans) sur le terminal et le ruban. Quand le
;; ruban est lu, on ignore toute entrée sur le terminal sauf CTRL-A
;; et ESC.
;; (ext:with-keyboard
;; (loop
;; for ch = (read-char-no-hang ext:*keyboard-input*)
;; until (equalp ch #S(SYSTEM::INPUT-CHARACTER :CHAR NIL :BITS 1 :FONT 0 :KEY #\C))
;; do (when ch (print ch))))
;;
;;
;; NIL or:
;; #S(SYSTEM::INPUT-CHARACTER :CHAR #\f :BITS 0 :FONT 0 :KEY NIL)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR #\s :BITS 0 :FONT 0 :KEY NIL)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR #\c :BITS 0 :FONT 0 :KEY NIL)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR #\s :BITS 0 :FONT 0 :KEY NIL)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR #\x :BITS 0 :FONT 0 :KEY NIL)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR NIL :BITS 1 :FONT 0 :KEY #\S)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR NIL :BITS 1 :FONT 0 :KEY #\S)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR NIL :BITS 1 :FONT 0 :KEY #\C)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR #\q :BITS 0 :FONT 0 :KEY NIL)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR NIL :BITS 1 :FONT 0 :KEY #\C)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR NIL :BITS 1 :FONT 0 :KEY #\C)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR NIL :BITS 1 :FONT 0 :KEY #\C)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR NIL :BITS 1 :FONT 0 :KEY #\Q)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR NIL :BITS 1 :FONT 0 :KEY #\Q)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR NIL :BITS 1 :FONT 0 :KEY #\C)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR NIL :BITS 1 :FONT 0 :KEY #\C)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR NIL :BITS 1 :FONT 0 :KEY #\Z)
;; #S(SYSTEM::INPUT-CHARACTER :CHAR #\Escape :BITS 0 :FONT 0 :KEY NIL)
;; (defun io-valid-tape-name-p (name)
;; "
;; RETURN: Whether name is a string with the following format:
;; name ::= part | part '/' name .
;; part ::= [A-Za-z][A-Za-z0-9]{0,4} /
;; "
;; (do ((i 0)
;; (l 0)
;; (state :first))
;; ((>= i (length name)) t)
;; (if (eq state :first)
;; (if (alpha-char-p (char name i))
;; (setf i (1+ i) l 1 state :rest)
;; (return-from io-valid-tape-name-p nil))
;; (cond
;; ((alphanumericp (char name i))
;; (setf i (1+ i) l (1+ l))
;; (when (> l 5) (return-from io-valid-tape-name-p nil)))
;; ((char= (character "/") (char name i))
;; (setf i (1+ i) state :first))
;; (t
;; (return-from io-valid-tape-name-p nil))))))
;;
;;
;; (defmethod io-redirect-input-from-tape ((task t) tape-name)
;; "
;; RETURN: The task-tape-input or nil.
;; "
;; (when (task-tape-input task)
;; (close (task-tape-input task))
;; (setf (task-tape-input task) nil))
;; (setf (task-input task) (terminal-input-stream (task-terminal task)))
;; (let ((path (catalog-make-path :tape name)))
;; (if path
;; (if (setf (task-tape-input task)
;; (open path :direction :input :if-does-not-exists nil))
;; (setf (task-input task) (task-tape-input task))
;; (error 'file-error-file-is-inaccessible :pathname path))
;; (error 'file-error-file-does-not-exist :pathname path)))
;; (task-tape-input task))
;;
;;
;; (defmethod io-redirect-output-to-tape ((task t) tape-name)
;; "
;; RETURN: The task-tape-output or nil.
;; "
;; (when (task-tape-output task)
;; (close (task-tape-output task))
;; (setf (task-tape-output task) nil))
;; (setf (task-output task) (terminal-output-stream (task-terminal task)))
;; (let ((path (catalog-make-path :tape name)))
;; (if path
;; (if (setf (task-tape-output task)
;; (open path :direction :output
;; :if-does-not-exists :create
;; :if-exists :supersede))
;; (setf (task-output task) (task-tape-output task))
;; (error 'file-error-file-is-inaccessible :pathname path))
;; (error 'file-error-file-does-not-exist :pathname path)))
;; (task-tape-output task))
......@@ -73,7 +73,7 @@
(defvar *debug-swank* nil)
(defvar *debug-swank* #+debugging t #-debugging nil)
;; (setf *debug-swank* t)
;; (setf *debug-swank* nil)
......@@ -424,15 +424,18 @@ contents of the OUTPUT-BUFFER, moving the cursor to the CURRENT-COLUMN."
(return-from get-a-byte #\Newline))
(t
(terminal-fill-input-buffer terminal))))))
#+debugging
(when (null ch)
(terminal-write-string terminal (format nil "~%input-buffer = ~S~%" (list input-cursor input-finished input-buffer))))
(terminal-write-string terminal
(format nil "~%input-buffer = ~S~%"
(list input-cursor input-finished input-buffer))))
ch)))
(defmethod io-skip-characters ((terminal swank-terminal) characters)
(defmethod terminal-skip-characters ((terminal swank-terminal) characters)
(loop
:named reading
:for ch = (io-read-buffered-character terminal)
:for ch = (terminal-read-buffered-character terminal)
:while (find ch characters)
:finally (let ((ch (terminal-keysym-character terminal ch)))
(with-slots (input-buffer input-cursor) terminal
......@@ -446,7 +449,7 @@ contents of the OUTPUT-BUFFER, moving the cursor to the CURRENT-COLUMN."
(incf (fill-pointer input-buffer))
(replace input-buffer input-buffer :start1 0 :start2 1)
(setf (aref input-buffer 0) ch))
(t ;; should not occur since we've just called io-read-buffered-character
(t ;; should not occur since we've just called terminal-read-buffered-character
(lse-error "ERREUR INTERNE: LIMITE DE TAILLE DE TAMPON D'ENTRÉE ATTEINTE")))))))
;;;; THE END ;;;;
......@@ -2,9 +2,10 @@
10 afficher[/,'Saisir le port: '];lire port
12 port_ent(port);si 1024<port et port<65536 alors aller en 20
14 afficher[/,'Port ',u,' invalide.',/]port;aller en 10
20 chaine host;host_'127.0.0.1'
30 chaine expr;expr_'(let ((swank::*loopback-interface* "'!host!'"))(swank:create-server :port '!cca(port)!'))'
35 chaine result;result_lisp('(ql:quickload :swank)',1,0);afficher[u,/]result
20 chaine host,expr,result
25 host_'127.0.0.1'
30 result_lisp('(ql:quickload :swank)',1,0);afficher[u,/]result
35 expr_'(let ((swank::*loopback-interface* "'!host!'")) (swank:create-server :port '!cca(port)!'))'
40 result_lisp(expr,1,0);afficher[u,/]result
50 terminer
......@@ -117,6 +117,7 @@
(when (characterp keysym)
keysym)))))
(defgeneric terminal-keysym-label (terminal keysym)
(:documentation "
Maps the keysym to a string describing the key-chord that must be typed on that terminal.
......@@ -143,42 +144,26 @@ KEYSYM: (MEMBER :ESCAPE :ATTENTION :XOFF :DELETE :RETURN)
(read-char stream nil nil)))
(defgeneric io-read-buffered-character (source)
(defgeneric terminal-read-buffered-character (source)
(:documentation "
Return a character or a keyword representing a key, read from a
possibly buffered source. The possible keywords are: :xoff :delete
:return
When this function receives the escape character (ESC), it signals a
USER-INTERRUPT condition with SIGINT+ as USER-INTERRUPT-SIGNAL.
When it receives the attention character (C-a), it signals a
USER-INTERRUPT with +SIGQUIT+ as USER-INTERRUPT-SIGNAL.
Those user-interrupt can be implemented by the kernel terminal driver,
instead of methods of this functions for some implementations.
Upon end-of-file, NIL is returned.
")
(:method (source)
(let* ((ch (terminal-get-next-char source))
(keysym (terminal-character-keysym source ch)))
(case keysym
((:escape)
(signal 'user-interrupt :signal +sigint+)
(io-read-buffered-character source))
((:attention)
(signal 'user-interrupt :signal +sigquit+)
(io-read-buffered-character source))
(otherwise
keysym)))))
#+lse-input-debug (io-format *task* "~%terminal-get-next-char -> ~A .~A.~%" ch (when (characterp ch) (char-code ch)))
keysym)))
(defgeneric io-skip-characters (source characters)
(defgeneric terminal-skip-characters (source characters)
(:documentation "
Read characters with IO-READ-BUFFERED-CHARACTER while they're in
Read characters with TERMINAL-READ-BUFFERED-CHARACTER while they're in
the sequence CHARACTERS. The first character out of that sequence
will be read by the next IO-READ-BUFFERED-CHARACTER call.
will be read by the next TERMINAL-READ-BUFFERED-CHARACTER call.
")
(:method ((stream stream) characters)
(loop
......@@ -379,12 +364,12 @@ When false, no automatic echo occurs.")
ch))
(defmethod io-skip-characters ((terminal standard-terminal) characters)
(defmethod terminal-skip-characters ((terminal standard-terminal) characters)
(loop
:named reading
:for ch = (io-read-buffered-character terminal)
:for ch = (terminal-read-buffered-character terminal)
:when (null ch)
:do (return-from io-skip-characters)
:do (return-from terminal-skip-characters)
:while (find ch characters)
:finally (unread-char (terminal-keysym-character terminal ch)
(terminal-input-stream terminal))))
......
......@@ -38,11 +38,16 @@
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(in-package "COM.INFORMATIMAGO.LSE.UNIX-TERMINAL")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; TERMIOS
;;;
(defun termios-attributes (fd &optional action)
"Allocates a new termios foreign structure, fills it with current
values for the specified file descriptor FD, and return it.
......@@ -404,6 +409,7 @@ RETURN: A sublist of options that didn't change successfully;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; UNIX-TERMINAL
;;;
(defclass unix-terminal (standard-terminal)
......@@ -417,8 +423,7 @@ RETURN: A sublist of options that didn't change successfully;
:initform nil
:reader terminal-modern-mode
:documentation "
This must be set before TERMINAL-INITIALIZE is called.
When false (default), the terminal works like on the MITRA-15 LSE System:
When NIL (default), the terminal works like on the MITRA-15 LSE System:
C-s (X-OFF) to send input to the computer.
C-a (SOH) to send a signal to the program.
\ to \"erase\" the previous character.
......@@ -434,7 +439,7 @@ When true, the terminal works more like a modern unix terminal;
:accessor terminal-cr-as-xoff
:documentation "
When true, CR works like XOFF, without being read into strings.
Valid only whe MODERN-MODE is false.
Valid only when MODERN-MODE is false.
")
(terminfo :initarg :terminfo
:initform (terminfo:set-terminal (getenv "TERM"))
......@@ -475,13 +480,14 @@ Valid only whe MODERN-MODE is false.
(defmethod (setf terminal-modern-mode) (new-mode (terminal unix-terminal))
(with-slots (modern-mode
input-file-descriptor
input-file-descriptor saved-termios
vintr vquit vsusp vkill veof veol veol2
verase vwerase vreprint vstart vstop) terminal
(if new-mode
;; Modern mode: get the characters from the termios.
(let ((ccs (lispify-control-characters
(termios-attributes input-file-descriptor))))
(or saved-termios
(termios-attributes input-file-descriptor)))))
(setf vintr (or (plist-get ccs :vintr) 0)
vquit (or (plist-get ccs :vquit) 0)
vsusp (or (plist-get ccs :vsusp) 0)
......@@ -510,23 +516,21 @@ Valid only whe MODERN-MODE is false.
vreprint 0
vstart 0
vstop 0))
;; #+developing
;; (progn
;; (format *trace-output* "~%TERMINAL MODE = ~:[OLD~;MODERN~]~%" new-mode)
;; (format *trace-output* "~@{~12A ~A~%~}"
;; :vintr vintr
;; :vquit vquit
;; :vsusp vsusp
;; :vkill vkill
;; :veof veof
;; :veol veol
;; :veol2 veol2