;;;; -*- 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))))