File psl-1983/3-1/nmode/nmode-break.sl artifact 8eea19dd9a on branch master

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% NMODE-BREAK.SL - NMODE Break Handler
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        26 August 1982
%
% Adapted from Will Galway's EMODE
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load objects))
(fluid '(*NMODE-RUNNING
	 *nmode-init-running
	 *OutWindow
	 nmode-terminal
	 nmode-command-argument
	 nmode-buffer-channel))

(fluid '(BreakLevel* *QuitBreak BreakEval* BreakName* ERROUT* ErrorForm*))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% We redefine BREAK (the break handler) and YESP.
% Grab the original versions (if we can find them!).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(if (FUnboundP 'pre-nmode-break)
    (CopyD 'pre-nmode-break
	   (if (FUnboundP 'pre_rawio_break)
		'break
		'pre_rawio_break
		)))

(if (FUnboundP 'pre-nmode-yesp)
    (CopyD 'pre-nmode-yesp 'yesp))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Initialization:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de enable-nmode-break ()
  (let ((*usermode NIL)
	(*redefmsg NIL)
	)
    (CopyD 'break 'nmode-break)
    (CopyD 'yesp 'nmode-yesp)
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Break handler:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de nmode-break ()
  (cond (*NMODE-RUNNING (nmode-break-handler))
	(t
	 (let ((old-raw-mode (=> nmode-terminal raw-mode)))
	   (leave-raw-mode)
	   (prog1
	    (pre-nmode-break)
	    (if old-raw-mode (enter-raw-mode))
	    )))))

(de nmode-break-handler ()
  (let* ((BreakLevel* (+ BreakLevel* 1))
	 (*QuitBreak T)
	 (BreakEval* 'Eval)
	 (BreakName* "NMODE Break")
	 (OldIN* IN*)
	 (OldOUT* OUT*)
	 (nmode-error? (eq in* 0))
	 (nmode-channel? (eq in* nmode-buffer-channel))
	 (init-error? *nmode-init-running)
	 (old-raw-mode (=> nmode-terminal raw-mode))
	 (*OutWindow T) % always pop up on a break
	 (*nmode-init-running NIL) % ditto
	 (*NMODE-RUNNING (not nmode-error?))
	 )
    (cond (nmode-error?
	   (leave-raw-mode)
	   (RDS 0)
	   (WRS 1)
	   )
	  (t
	   (RDS nmode-buffer-channel)
	   (WRS nmode-buffer-channel)
	   (enter-raw-mode)
	   ))
    (when init-error?
      (Printf "Error occurred while executing your NMODE INIT file!%n")
      (Ding)
      )
    (unwind-protect
      (Catch '$Break$
	(TopLoop 'Read 'Print 'BreakEval BreakName* "NMODE Break loop")
	)
      (RDS OldIN*)
      (WRS OldOUT*)
      (if old-raw-mode (enter-raw-mode))
      )
    (if *QuitBreak
	(let ((*Break NIL)
	      (*EmsgP NIL)
	      )
	  (StdError "Exit to ErrorSet")))
    )
  (Eval ErrorForm*)
  )

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Break command functions:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de lisp-quit-command ()
  (cond ((ensure-in-break)
	 (setf *QuitBreak T)
	 (throw '$Break$ NIL)
	 )))

(de lisp-retry-command ()
  (cond ((ensure-in-break)
	 (cond (*ContinuableError
		 (setf *QuitBreak NIL)
		 (throw '$Break$ NIL)
		 )
	       (t
		(write-prompt "Cannot retry: error is not continuable.")
		(Ding)))
	 )))

(de lisp-continue-command ()
  (cond ((ensure-in-break)
	 (cond (*ContinuableError
		 (setf ErrorForm* (MkQuote BreakValue*))
		 (setf *QuitBreak NIL)
		 (throw '$Break$ NIL)
		 )
	       (t
		(write-prompt "Cannot continue: error is not continuable.")
		(Ding)))
	 )))

(de lisp-abort-command ()
  (cond ((ensure-in-break)
	 (reset))))

(de lisp-backtrace-command ()
  (cond ((ensure-in-break)
	 (nmode-select-buffer-channel)
	 (cond ((>= nmode-command-argument 16) (VerboseBackTrace))
	       ((>= nmode-command-argument 4) (InterpBackTrace))
	       (t (BackTrace)))
	 (nmode-select-old-channels)
	 )))

(de lisp-help-command ()
  (write-message
   (if (> BreakLevel* 0)
    "Lisp break commands: Q-quit;A-abort;R-retry;C-continue;B-backtrace"
    "Lisp commands: E-execute form;Y-yank last output;L-invoke Lisp Listener"
    )))

(de ensure-in-break ()
  (if (> BreakLevel* 0)
      T
      (write-prompt "Not in a break loop!")
      (Ding)
      NIL
      ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Query functions:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de nmode-yesp (message)
  (cond ((and *NMODE-RUNNING (=> nmode-terminal raw-mode))
	 (nmode-yes-or-no? message))
	(t (pre-nmode-yesp message))
	))

(de nmode-yes-or-no? (message)
  (let ((response (prompt-for-string message NIL)))
    (while T
      (cond ((string-equal response "Yes") (exit T))
	    ((string-equal response "No") (exit NIL))
	    (t (Ding)
	       (write-prompt "Please answer YES or NO.")
	       (sleep-until-timeout-or-input 60)
	       (setf response (prompt-for-string message NIL))
	       )))))

(de nmode-y-or-n? (message)
  (write-message message)
  (nmode-set-immediate-prompt "Y or N: ")
  (let ((answer
	 (while T
	   (let ((ch (char-upcase (input-direct-terminal-character))))
	     (when (= ch #/Y) (nmode-complete-prompt "Y") (exit T))
	     (when (= ch #/N) (nmode-complete-prompt "N") (exit NIL))
	     (when (= ch #\BELL) (exit 'ABORT))
	     (Ding)
	     ))))
    (set-prompt "")
    (write-message "")
    (if (eq answer 'ABORT) (throw 'ABORT NIL))
    answer
    ))