reduce-historical/psl-1983/nmode/lisp-interface.sl

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% LISP-Interface.SL - NMODE Lisp Text Execution Interface
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        23 August 1982
% Revised:     14 February 1983
%
% Adapted from Will Galway's EMODE
%
% 14-Feb-83 Alan Snyder
%  Added statement to flush output buffer cache.
% 2-Feb-83 Alan Snyder
%  Added Execute-Defun-Command.  Change to supply the free EOL at the end of
%  the input buffer whenever the buffer-modified flag is set, instead of only
%  when currently at the end of the buffer.
% 25-Jan-83 Alan Snyder
%  Check terminal type after resuming.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load objects))

(fluid '(nmode-current-buffer
	 nmode-output-buffer
	 nmode-terminal
	 nmode-initialized
	 *NMODE-RUNNING
	 *GC
	 LispBanner*
	 *RAWIO
	 *nmode-init-running
	 *nmode-init-has-run
	 nmode-terminal-input-buffer
	 nmode-default-init-file-name
	 nmode-auto-start
	 nmode-first-start
	 ))

(setf *NMODE-RUNNING NIL)
(setf *nmode-init-running NIL)
(setf *nmode-init-has-run NIL)
(setf nmode-default-init-file-name "PSL:NMODE.INIT")
(setf nmode-auto-start NIL)
(setf nmode-first-start T)

(fluid '(
	 nmode-buffer-channel	% Channel used for NMODE I/O.
	 nmode-output-start-position  % Where most recent "output" started in buffer.
	 nmode-output-end-position  % Where most recent "output" ended in buffer.
	 OldStdIn
	 OldStdOut
	 OldErrOut
	 ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de yank-last-output-command ()
  % Insert "last output" typed in the OUTPUT buffer.  Output is demarked by
  % NMODE-OUTPUT-START-POSITION and NMODE-OUTPUT-END-POSITION.

  (if (not nmode-output-start-position)
    (Ding)
    % Otherwise
    (let ((text (=> nmode-output-buffer
		    extract-region
		    NIL
		    nmode-output-start-position
		    (or nmode-output-end-position
			(buffer-position-create (=> nmode-output-buffer size) 0)
			)
		    )))
      (=> nmode-current-buffer insert-text (cdr text))
      )))

(de execute-form-command ()
  % Execute starting at the beginning of the current line.

  (set-mark-from-point) % in case the user wants to come back
  (move-to-start-of-line)
  (execute-from-buffer)
  )

(de execute-defun-command ()
  % Execute starting at the beginning of the current defun (if the current
  % position is within a defun) or from the current position (otherwise).

  (set-mark-from-point) % in case the user wants to come back
  (move-to-start-of-current-defun)
  (execute-from-buffer)
  )

(de make-buffer-terminated ()
  % If the current buffer ends with an "unterminated" line, add an EOL to
  % terminate it.

  (let ((old-pos (buffer-get-position)))
    (move-to-buffer-end)
    (when (not (current-line-empty?)) (insert-eol))
    (buffer-set-position old-pos)
    ))

(de execute-from-buffer ()
  % Causes NMODE to return to the procedure that called it (via
  % nmode-channel-editor) with input redirected to come from the (now) current
  % buffer.  We arrange for output to go to the end of the output buffer.

  (if (=> nmode-current-buffer modified?) (make-buffer-terminated))
  (buffer-channel-set-input-buffer nmode-buffer-channel nmode-current-buffer)

  % Output will go to end of the output buffer.  Supply a free EOL if the last
  % line is unterminated.  Record the current end-of-buffer for later use by
  % Lisp-Y.

  (let ((old-pos (=> nmode-output-buffer position)))
    (=> nmode-output-buffer move-to-buffer-end)
    (if (not (=> nmode-output-buffer current-line-empty?))
      (=> nmode-output-buffer insert-eol))
    (setf nmode-output-start-position (=> nmode-output-buffer position))
    (=> nmode-output-buffer set-position old-pos)
    )

  % Set things up to read from and write to NMODE buffers.
  (nmode-select-buffer-channel)
  (exit-nmode-reader)
  )

(de nmode-exit-to-superior ()
  (if (not *NMODE-RUNNING)
    (original-quit)
    % else
    (leave-raw-mode)		% Turn echoing back on.  Next refresh is FULL.
    (original-quit)
    (enter-raw-mode)		% Turn echoing off.
    (nmode-set-terminal)	% Ensure proper terminal driver is loaded.
    ))

% Redefine QUIT so that it restores the terminal to echoing before exiting.
(when (FUnboundP 'original!-quit)
  (CopyD 'original!-quit 'quit)
  (CopyD 'quit 'nmode-exit-to-superior)
  )

(de emode () (nmode)) % for user convenience

(de nmode ()

  % Rebind the PSL input channel to the NMODE buffer channel and return.  This
  % will cause the next READ to invoke Nmode-Channel-Editor and start running
  % NMODE.  Use the function "exit-nmode" to switch back to original channels.

  (nmode-initialize) % does nothing if already initialized
  (when (neq STDIN* nmode-buffer-channel)
    (setf OldStdIn STDIN*)
    (setf OldStdOut STDOUT*)
    (setf OldErrOut ErrOut*)
    )
  (nmode-select-buffer-input-channel)
  )

(de nmode-run-init-file ()
  (setf *nmode-init-has-run T)
  (let ((fn (namestring (init-file-pathname "NMODE"))))
    (cond ((FileP fn)
	   (nmode-execute-init-file fn))
	  ((FileP (setf fn nmode-default-init-file-name))
	   (nmode-execute-init-file fn))
	  )))

(de nmode-execute-init-file (fn)
  (let ((*nmode-init-running T))
    (nmode-read-and-evaluate-file fn)
    ))

(de nmode-read-and-evaluate-file (fn)
  (let ((chn (open fn 'INPUT))
	exp
	)
    (while (not (eq (setf exp (ChannelRead chn)) $Eof$))
      (eval exp)
      )
    (close chn)
    )
  )

(de exit-nmode ()
  % Leave NMODE, return to normal listen loop.
  (nmode-select-old-channels)
  (=> nmode-terminal move-cursor (=> nmode-terminal maxrow) 0)
  (leave-raw-mode)
  (setf *NMODE-RUNNING NIL)
  (setf *GC T)
  (exit-nmode-reader) % Set flag to cause NMODE to exit.
  )

% The following function is not currently used.
(de nmode-invoke-lisp-listener ()
  % Invoke a normal listen loop.
  (let* ((*NMODE-RUNNING NIL)
	 (OldIN* IN*)
	 (OldOUT* OUT*)
	 (ERROUT* 1)
	 (StdIn* 0)
	 (StdOut* 1)
	 (old-raw-mode (=> nmode-terminal raw-mode))
	 )
    (leave-raw-mode)
    (RDS 0)
    (WRS 1)
    (unwind-protect
     (TopLoop 'Read 'Print 'Eval "Lisp" "Return to NMODE with ^Z")
     (RDS OldIN*)
     (WRS OldOUT*)
     (if old-raw-mode (enter-raw-mode))
     )))
% (de emode () (throw '$read$ $eof$)) % use with above function
% (de nmode () (throw '$read$ $eof$)) % use with above function

(de nmode-select-old-channels ()
  % Select channels that were in effect when "Lisp Interface" was started up.
  % (But don't turn echoing on.)  NOTE that the "old channels" are normally
  % selected while NMODE is actually running (this is somewhat counter
  % intuitive).  This is so that any error messages created by bugs in NMODE
  % will not be printed into NMODE buffers.  (If they were, it might break
  % things recursively!)

  (setf STDIN* OldStdIn)
  (setf STDOUT* OldStdOut)
  (setf ErrOut* OldErrOut)
  (RDS STDIN*)    % Select the channels.
  (WRS STDOUT*)
  )

(de nmode-select-buffer-channel ()
  % Select channels that read from and write to NMODE buffers.
  (nmode-select-buffer-input-channel)
  (setf STDOUT* nmode-buffer-channel)
  (setf ErrOut* nmode-buffer-channel)
  (WRS STDOUT*)
  )

(de nmode-select-buffer-input-channel ()
  % Select channel that reads from NMODE buffer.  "NMODE-Channel-Editor" is
  % called when read routines invoke the "editor routine" for the newly selected
  % channel.

  (if (null nmode-buffer-channel)
    (setf nmode-buffer-channel
      (OpenBufferChannel NIL nmode-output-buffer 'nmode-channel-editor)))
  (setf STDIN* nmode-buffer-channel)
  (RDS STDIN*)
  )

(de nmode-channel-editor (chn)

  % This procedure is called every time that input is requested from an NMODE
  % buffer.  It starts up NMODE (if not already running) and resumes NMODE
  % execution.  When the user has decided on what input to give to the channel
  % (by performing Lisp-E), the NMODE-reader will return with I/O bound to the
  % "buffer channel".  The reader will also return if the user performs Lisp-L,
  % in which case I/O will remain bound to the "standard" channels.

  % Select "old" channels, so if an error occurs we don't get a bad recursive
  % situation where printing into a buffer causes more trouble!

  (nmode-select-old-channels)
  (cond ((not *NMODE-RUNNING)
	 (setf *NMODE-RUNNING T)
	 (setf *GC NIL)
	 (if (not *nmode-init-has-run)
	   (nmode-run-init-file)
	   )
	 )
	(t
	 (buffer-channel-flush nmode-buffer-channel)
	 (setf nmode-output-end-position (=> nmode-output-buffer position))
	 % compensate for moving to line start on next Lisp-E:
	 (if (not (at-line-start?))
	   (move-to-next-line))
         )
	)
  (enter-raw-mode)
  (nmode-select-major-window) % just in case
  (NMODE-reader NIL) % NIL => don't exit when a command aborts
  )

(de nmode-main ()
  (setf CurrentReadMacroIndicator* 'LispReadMacro) % Crock!
  (setf CurrentScanTable* LispScanTable*)
  (when (not toploopread*)
    (setf toploopread* 'read)
    (setf toploopprint* 'print)
    (setf toploopeval* 'eval)
    (setf toploopname* "NMODE Lisp")
    )
  (nmode-initialize) % does nothing if already initialized
  (nmode-set-terminal) % ensure proper terminal driver is loaded

  % Note: RESET may cause echoing to be turned on without clearing *RawIO.
  (when *RawIO
    (setf *RawIO NIL)
    (EchoOff)
    )

  (when nmode-first-start
    (setf nmode-first-start NIL) % never again
    (cond (nmode-auto-start
	   (setf *NMODE-RUNNING T) % see below
           (let ((was-modified? (=> nmode-output-buffer modified?)))
	     (=> nmode-output-buffer insert-line LispBanner*)
	     (if (not was-modified?)
	       (=> nmode-output-buffer set-modified? NIL)
	       )))
	  (t
	   (printf "%w%n" LispBanner*)
	   ))
    )

  (while T
    (setf nmode-terminal-input-buffer NIL) % flush execution from buffers
    (cond (*NMODE-RUNNING
	   (setf *NMODE-RUNNING NIL) % force full start-up
	   (nmode) % cause next READ to start up NMODE
	   )
	  (t
	   (RDS 0)
	   (WRS 1)
	   ))
    (nmode-top-loop)
    ))

(copyd 'main 'nmode-main)

(de nmode-top-loop ()
  (TopLoop toploopread* toploopprint* toploopeval* toploopname* "")
  (Printf "End of File read!")
  )