COMRED - Lisp library for emulating the TOPS-20 command line.

build/build.tcl

@@ -762,6 +762,12 @@ type ":kill\r"
 respond "*" ":lisp libdoc;od (dump)\r"
 expect ":KILL"
 
+# comred
+respond "*" "complr\013"
+respond "_" "liblsp;_libdoc; comred\r"
+respond "_" "\032"
+type ":kill\r"
+
 respond "*" ":link inquir;lsrtns 1,syseng;lsrtns >\r"
 
 respond "*" ":midas inquir;ts lookup_inquir;lookup\r"

src/libdoc/comred.1

@@ -0,0 +1,132 @@
+;;;; -*- 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))))