mirror of
https://github.com/PDP-10/its.git
synced 2026-01-18 01:02:15 +00:00
133 lines
3.0 KiB
Common Lisp
133 lines
3.0 KiB
Common Lisp
;;;; -*- LISP -*-
|
||
;;;; Lisp library emulating the TOPS-20 command line COMND.
|
||
|
||
(herald comred)
|
||
|
||
(load "liblsp;tty")
|
||
|
||
(defvar *comred-prompt* "COMRED>")
|
||
(defvar *comred-command* nil)
|
||
(defvar *comred-forced* t)
|
||
(defvar *input* nil)
|
||
|
||
(defun comred-initialize ()
|
||
"Initialize library."
|
||
nil)
|
||
|
||
(defmacro defspec (symbol () help-text error-text)
|
||
"Define a command named by the symbol."
|
||
`(progn
|
||
(putprop ',symbol ,help-text 'help-text)
|
||
(putprop ',symbol ,error-text 'error-text)))
|
||
|
||
(defun comspec-add-items (symbol list x)
|
||
"Adds all subcommands in list to the command named by symbol."
|
||
(putprop symbol (append list (get symbol 'commands)) 'commands)
|
||
symbol)
|
||
|
||
(defmacro when (x &rest body)
|
||
`(if ,x (progn ,@body)))
|
||
|
||
(defun upcase (string)
|
||
(do ((x string (cdr x))
|
||
(y nil))
|
||
((null x) (implode y))
|
||
(let ((z (car x)))
|
||
(when (<= 141 z 172)
|
||
(setq z (- z 40)))
|
||
(push z y))))
|
||
|
||
(defun comred-commands ()
|
||
(get *comred-command* 'commands))
|
||
|
||
(defun comred-command-p (command)
|
||
(do ((x (comred-commands) (cdr x)))
|
||
((null x) nil)
|
||
(when (samepnamep command (car x))
|
||
(return t))))
|
||
|
||
(defun comred-error ()
|
||
(terpri)
|
||
(princ (get *comred-command* 'error-text))
|
||
(terpri))
|
||
|
||
(defmacro dolist ((var form) &rest body)
|
||
(let ((x (gensym)))
|
||
`(do ((,x ,form (cdr ,x)))
|
||
((null ,x))
|
||
(let ((,var (car ,x)))
|
||
,@body))))
|
||
|
||
(defun comred-erase ()
|
||
(when *input*
|
||
(pop *input*)
|
||
(princ " ")))
|
||
|
||
(defun comred-prompt (&optional guide)
|
||
(cond
|
||
(guide
|
||
(setq *comred-forced* t)
|
||
(princ " ")
|
||
(princ *comred-prompt*))
|
||
(t
|
||
(when *comred-prompt*
|
||
(terpri)
|
||
(princ *comred-prompt*)))))
|
||
|
||
(defun comred-question ()
|
||
(terpri)
|
||
(princ "Commands:")
|
||
(dolist (x (comred-commands))
|
||
(terpri)
|
||
(princ x)
|
||
(when (get x 'help-text)
|
||
(princ " - ")
|
||
(princ (get x 'help-text))))
|
||
(comred-prompt)
|
||
(princ (implode (reverse *input*))))
|
||
|
||
(defun comred-readline ()
|
||
(do-with-tty-off
|
||
(setq *input* nil)
|
||
(do ((ch (tyi) (tyi)))
|
||
((memq ch '(#\Return #\Space)) (upcase *input*))
|
||
(caseq ch
|
||
((#^J #^C)) ;Ignore
|
||
((#^H #^?) (comred-erase))
|
||
(#/? (comred-question))
|
||
(t (tyo ch) (push ch *input*))))))
|
||
|
||
(defun comred (symbol)
|
||
"Prompt, and read a subcommand for the command named by symbol."
|
||
(caseq symbol
|
||
(confirm (terpri))
|
||
(text-string (comred-readline))
|
||
(t
|
||
(do ((*comred-command* symbol))
|
||
(nil)
|
||
(when (not *comred-forced*)
|
||
(comred-prompt))
|
||
(setq *comred-forced* nil)
|
||
(let ((x (comred-readline)))
|
||
(cond
|
||
((equal (pnget x 7) '(0)))
|
||
((comred-command-p x)
|
||
(setq *comred-prompt* nil)
|
||
(return x))
|
||
(t (comred-error))))))))
|
||
|
||
(defun comred-force-guideword (text)
|
||
"Print guide text."
|
||
(setq *comred-prompt*
|
||
(implode (nconc (exploden text)
|
||
(exploden " "))))
|
||
(comred-prompt 'forced))
|
||
|
||
(defmacro let-comred (text &rest body)
|
||
"Set prompt to text for the first call to comred inside the body."
|
||
`(do (result
|
||
(*comred-prompt* ,text)
|
||
(*comred-forced* nil))
|
||
(result)
|
||
(setq result (progn ,@body))))
|