Artifact 3585e1b8a19543f8b4947a991fdf5b9989e13250d62488d132b6c9bcd3f23649:

• File psl-1983/3-1/nmode/process.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 17229) [annotate] [blame] [check-ins using] [more...]

%
% PROCESS.SL
%    Routines to support  generalized inferior processes in TOPS20 PSL.
%    Much of the code is based on PHOTO.FAI
%
%  Mark R. Swanson
%  University of Utah
%  June 17, 1983
%

(load objects monsym jsys)
(fluid '(current-process
	  process-list
	  nmode-selectable-processes))
		
(setf current-process nil)
(setf process-list nil)
(setf nmode-selectable-processes ())

(de create-process-stream (name b)
  (let ((process (make-instance 'process-stream
				'exe-file-name name
				'out-buf b)))
    process))

(defflavor process-stream (
   (sys-proc-id 0)
   ttyjfn
   ptyjfn
   (exe-jfn -1)
   exe-file-name
   out-buf
   output-end
   mode-word
   string-in
   status
   )
  ()
  (initable-instance-variables exe-file-name out-buf)
  (gettable-instance-variables ttyjfn 
			       out-buf mode-word
			       status exe-file-name
			       sys-proc-id)
)

(defmethod (process-stream init) ()
        (=> self getjfn)        % get jfn for executable
	(=> self getpty)	% get a jfn for pty
        (=> self efork)		% create an inferior fork and attach it to PTY
	(=> self setpty)	% set up pty parameters, links, etc.
	(=> self runfrk)        % start up the fork
	)

(defmethod (process-stream write-to-process) (string)
  % Send the given string to the inferior process thru the PTY,  but do not
  %  block if buffer is full (for whatever reason).  Also, only dole out the
  %  string in bite-size pieces.
  %  91 seems to be a magic number, as far as tty buffers go.

  (let ((str-len (add1 (size string)))
	(i 0)
	cur-sout-len)
  (while (and (timeout-wait 'accepting-output? (list ttyjfn) 60)
              (> str-len 0))
    (setf cur-sout-len (min 92 str-len))
    (jsys0 ptyjfn 
           (sub string i (sub1 cur-sout-len))
           cur-sout-len
           0 (const jsSOUT))
    (setf i (+ i cur-sout-len))
    (setf str-len (- str-len cur-sout-len)))
  (if (~= str-len 0)
    (write-message "Current process not accepting input"))
  ))

(de user-typed-input? ()
  % Return T if our user has typed something, NIL if not
  (~= (xsibe 8#100) 0))

(de accepting-output? (jfn)
  % See if PTY buffer is already filled to capacity
  (<= (xsibe jfn) 92))   % 8#91 is assumed not to exceed buffer capacity
                         %  of a PTY, but be enough to force process wakeup

% The following are provided to avoid unwanted error handling on the +1 return

(lap '((!*entry xsibe expr 1)
      (jsys (const jssibe))
      (jfcl)
      (!*move (reg 2) (reg 1))
      (!*exit 0)))

(lap '((!*entry xsobe expr 1)
      (jsys (const jssobe))
      (jfcl)
      (!*move (reg 2) (reg 1))
      (!*exit 0)))

(defmethod (process-stream read-into-buffer) ()
  % Reads output of inferior process into associated buffer, if any output
  %  is to be had;  waits only a *small* finite amount of time for input to
  %  appear.

  (let ((chars-read nil)
	(input-recvd nil))
    (=> out-buf move-to-buffer-end)    % New output should appear at buffer end
    (while  (and                       % Keep reading until no more output from
	     (not (user-typed-input?)) %  process  or user typein.
	     (setf chars-read (=> self read-from-process)))
      (setf input-recvd t)             % So we will know to refresh window.
      (let ((string string-in)
	    (i 0)
	    char)
	(while
	  (< i chars-read)
	  (if (~= (setf char (string-fetch string i)) #\cr) % ignore CR's
	    (=> out-buf insert-character char))
	  (setf i (+ i 1))
	  )))
    (setf output-end (=> out-buf position))
    (if input-recvd (=> self window-refresh)) % refresh window when all done
    ))
  
(defmethod (process-stream read-from-process) ()
  % READ-FROM-PROCESS reads as many chars as are waiting to be read into
  %  string-in and returns number read, or NIL if there were none.  Will
  %  not block if no output is available,  though it will wait a short 
  %  time for some to arrive.

  (let ((chars-to-read (timeout-wait 'output-waiting? (list ttyjfn) 20))
	)
    (if (null chars-to-read) (exit nil))
    (setf string-in (mkstring (- chars-to-read 1) 0))
    (- chars-to-read (jsys3 ptyjfn string-in chars-to-read 0 (const jsSIN)))
    ))

(de output-waiting? (jfn)
  % OUTPUT-WAITING? checks inferior process' tty output buffer to see if it's
  %  empty.  Returns NIL if it is empty, else the count of characters in buffer.

  (let ((n (xsobe jfn)))
    (if (= n 0) nil n)))

(defmethod (process-stream getjfn) ()
  % GETJFN -- get a jfn for executable file specified by exe-file-name
  (setf exe-jfn (jsys1 (bits 2 17) exe-file-name 0 0 (const jsGTJFN)))
  )

(defmethod (process-stream efork) ()
  % EFORK -- create an inferior fork and get a copy of the desired file into it
  (setf sys-proc-id (jsys1 (bits 1) 0 0 0 (const jsCFORK))) % create fork
  (jsys0 sys-proc-id 0 0 0 (const jsFFORK)) % freeze it
  (jsys0 (xword sys-proc-id exe-jfn) 0 0 0 (const jsGET)) % get the executable into it
  (jsys0 sys-proc-id                        % don't allow LOGOff or CTRL-C trap
	 (xword 8#200001 
		(lowhalfword (jsys2 sys-proc-id 0 0 0 (const jsRPCAP))))
	 0 0 (const jsEPCAP))
  (jsys0 sys-proc-id (xword ttyjfn ttyjfn) 0 0 (const jsSPJFN))
  )

(defmethod (process-stream runfrk) ()
  % RUNFRK -- run something in an inferior fork
  % returns with ERRFLG T if the fork terminated abnormally
  (jsys0 sys-proc-id 0 0 0 (const jsSFRKV))
  (jsys0 sys-proc-id 0 0 0 (const jsRFORK))
  (setf status (jsys1 sys-proc-id 0 0 0 (const jsRFSTS)))
  %  (setf error-flag (not (eqn 2 (land (loworderhalf status) 2))))
  )

% (defmethod (process-stream proc-sts) ()
% (setf status (jsys1 sys-proc-id 0 0 0 (const jsRFSTS)))
%  (setf mode-word (jsys2 ttyjfn 0 0 0 (const jsRFMOD)))
%  )

%(defmethod (process-stream running) ()
%  (not (eqn (land (highhalfword status) 8#400000) 8#400000)))

%(defmethod (process-stream io-wait) ()
%  (eqn (land (highhalfword status) 8#377777) 1))

(defmethod (process-stream getpty) ()
  % GETPTY - get a jfn on a pty and also its TTY number
  (let ((curpty (get-1-pty)))
    (cond ((eqn curpty -1)
	   (ErrorPrintF
	    "There are too many people using PTY's now; try again later.")))
    (setf ptyjfn (openpty (ptynum curpty)))
    (setf ttyjfn (openpty (ttynum curpty)))
    ))

(defmethod (process-stream intrpt-process) ()
  % essentially the same as ^C to the inferior
  (jsys0  sys-proc-id (bits 1) 0 0 (const jsIIC))
  )

(defmethod (process-stream close-pty) ()
  (jsys0 ptyjfn 0 0 0 (const jsCLOSF))
  (jsys0 ttyjfn 0 0 0 (const jsCLOSF))
  (setf ptyjfn 0)
  (setf ttyjfn 0)
  )

(defmethod (process-stream kill) ()
  % kil the fork, close its PTY's, reset fork handle
  (jsys0 sys-proc-id 0 0 0 (const jsKfork))
  (setf sys-proc-id 0)
  (=> self close-pty)
  )

(de get-1-pty ()
  % find an available PTY; note that TOPS20 will tell us that a PTY is available
  %  to us if we have it in use already--ensure that we get a new one.

  (for* (with dev-characteristics pty-owning-job
	      (numpty (HighHalfWord (jsys1 26 0 0 0 (const JsGETAB))))
	      (my-job-num (jsys3 -1 (xword -1 3) 0 0 (const jsGETJI))))
	(from curpty 0 numpty 1)
	(finally (return -1))	% in case none is found
	(do
	 (setf dev-characteristics 
	   (jsys2 (xword 8#600013 curpty) 0 0 0 (const JsDVCHR)))
	 (setf pty-owning-job 
	   (highhalfword (jsys3 (xword 8#600013 curpty) 0 0 0 (const JsDVCHR))))
	 (cond
	  ((and
	    (eqn 8#010000	   % is it available?
		 (land (highhalfword dev-characteristics) 8#010000)) % dv%av 
	    (not (eqn my-job-num    % does it already belong to us?
		      pty-owning-job)))
	   (return curpty))
	  )
	 )))

(de openpty (ptynum)
  %
  (let ((devnam (Mkstring 10))
	ptyjfn)
    (jsys0 devnam                  % turn Device descriptor into a name-string
	   (jsys1 ptynum 0 0 0 (const JsDVCHR))
	          0 0 (const JsDEVST))
    (setf devnam (recopystringtonull devnam)) % truncate it at NULL
    (setf ptyjfn                              % make it into a TOPS-20 dev name
      (jsys1 (Xword 8#001 0) (concat devnam ":") 0 0 (const JsGTJFN))) % gj%sht!gj%acc
    (jsys0 ptyjfn (Xword 8#70000 8#300000) 0 0 (const JsOPENF)) % 7 bit byte,in-out
    ptyjfn))

(de ttynum (ptynum)
% TTYNUM--given a PTY number, turn it into the device designator of the
%  associated TTY
  (plus ptynum 
	(LowHalfWord (jsys1 22 0 0 0 (const JsGETAB))) % 26 is the index of the PTY table
	8#400000)) % .ttdes

(de ptynum (ptynum)
  % PTYNUM--given a PTY number, turn it into a PTY device designator
  (xword 8#600013 ptynum))

(defmethod (process-stream setpty) ()
  % SETPTY-- set up PTY mode

  (jsys0 ttyjfn 8#525252525252 8#525252525252 0 (const jsSFCOC))
  (setf mode-word (jsys2 ttyjfn 0 0 0 (const jsRFMOD)))
  (jsys0 ttyjfn (land mode-word 8#777777774000) 0 0 (const jsSFMOD))
  (jsys0 ttyjfn (land mode-word 8#777777774000) 0 0 (const jsSTPAR))
  )

(defmethod (process-stream window-refresh) ()
  (when out-buf
    (if (and *OutWindow
	  (not (buffer-is-displayed? out-buf)))
      (nmode-expose-output-buffer out-buf))
    (let ((window-list (find-buffer-in-exposed-windows out-buf)))
      (when window-list
	(nmode-adjust-output-window (car window-list))
	))))
    
(defmethod (process-stream name) ()
  (=> out-buf name))


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

	
(de feed-process-from-buffer (terminate-flag)
  % Causes NMODE to send input to an inferior process from the current buffer.
  % Output will go to end of the output buffer.  Supply a free EOL if the last
  % line is unterminated.

  (if (null current-process) (write-message "No process")
    (if (=> nmode-current-buffer modified?) (make-buffer-terminated))
    (let* ((process-output-buffer (=> current-process out-buf))
	   (old-pos (=> process-output-buffer position))
	   (input-line (=> nmode-current-buffer current-line))
	   )
      (=> process-output-buffer set-mark-from-point)

      % Set things up to read from and write to NMODE buffers.
      (=> current-process write-to-process input-line)
      (if terminate-flag
	(=> current-process write-to-process (mkstring 0 #\lf)))
      (=> nmode-current-buffer move-to-next-line)
      (=> current-process read-into-buffer)
      )))

(de create-process-command ()
  (let* ((fn (prompt-for-file-name "Executable file: " "SYSTEM:EXEC.EXE"))
	  (nmode-default-mode process-mode)
	  (b (buffer-create-default
	       (buffer-make-unique-name
		 (filename-to-buffername fn))))
	  (process  (create-process-stream fn b)))
    (setf nmode-selectable-processes (cons process nmode-selectable-processes))
    (setf current-process process)
    ))
	
(de execute-region-command ()
  % Send region to inferior process; one line at a time.
  % NOT YET FULLY IMPLEMENTED
  (set-mark-from-point) % in case the user wants to come back
  (move-to-start-of-line)
  (feed-process-from-buffer t)
  )

(de execute-line-command ()
  % Send current line to inferior process; start at the beginning of the line.

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

(de execute-unterminated-line-command ()
  % Execute starting at the beginning of the current line, do not send an EOL.

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

(de intrpt-process-command ()
  (if (null current-process)
    (write-message "No process")
    (=> current-process intrpt-process)))

(de kill-process-command ()
  (if current-process
    (progn
     (=> current-process kill)
     (setf current-process (cadr nmode-selectable-processes))
     (setf nmode-selectable-processes (cdr nmode-selectable-processes)))
    (write-message "No process")))

(de send-char-immediate-command ()
  % Send the next character as is, without waiting for a line terminator
  %  Useful for sending control characters, and for talking to programs (such
  %  as DDT, that break on single, non-control characters such as "/"

  (if current-process
    (let ((ch (input-direct-terminal-character)))
      (=> current-process write-to-process (mkstring 0 ch))
      (=> current-process read-into-buffer))
    (write-message "No process")))

(de execute-from-input-window ()
  (if (null current-process) 
    (write-message "No process")
    %else
    (let* ((buf (=> current-process out-buf))
	   (prompt-string (progn
			   (=> buf move-to-buffer-end)
			   (=> buf current-line))))
     (=> current-process write-to-process (prompt-for-process-string 
					   prompt-string NIL))
     (=> current-process write-to-process (mkstring 0 #\lf))
     (=> current-process read-into-buffer))
    ))

(de cut-line-command ()
  (let ((cur-char-pos (current-char-pos))
	(cur-line (current-line)))
    (update-kill-buffer
     (cons 1 (vector (sub cur-line cur-char-pos
			  (- (size cur-line) cur-char-pos))))
     )))
				      
% A replacement for NMODE-READER-STEP (found in PN:READER.SL);  the only
%  change is to check for output from inferior process(es)

(de nmode-reader-step ()
  (cond ((not nmode-timing?)
	 (nmode-refresh)
	 (nmode-gc-check)
	 (nmode-process-output-check)
	 (nmode-read-command)
	 (nmode-execute-current-command)
	 )
	(t (nmode-timed-reader-step))
	))

(de nmode-process-output-check()
  % Check for output from the current (if there is one) process; read it if
  % there is any; the read should not block waiting for further output
  (cond ((and
	  current-process
	  (output-waiting?  (=> current-process ttyjfn)))
	 (=> current-process read-into-buffer)))
  T
  )

(de prompt-for-process-string (prompt-string restore-inserts?)
  % This function is similar to PROMPT-FOR-STRING.
  (setf nmode-input-special-command-list nil)
  (if restore-inserts?
    (self-inserting-command))
  (if (> nmode-input-level 0)
    (throw '$error$ NIL)
    % else
    (let ((old-msg nmode-message-string)
	  (old-window nmode-current-window)
	  (nmode-input-level (+ nmode-input-level 1)) % FLUID
	  )
      (=> (=> nmode-input-window buffer) reset)
      (nmode-select-window nmode-input-window)
      (set-message prompt-string)
      (set-prompt "") % avoid old prompt popping back up when we're done

      % Edit the buffer until an "exit" character is typed or the user aborts.

      (cond ((eq (NMODE-reader T) 'abort)
	     (=> nmode-input-window deexpose)
	     (nmode-select-window old-window)
	     (set-message old-msg)
	     (throw 'abort NIL)
	     ))

      % Show the user that his input has been accepted.
      (move-to-start-of-line)
      (nmode-refresh-one-window nmode-input-window)

      % Pick up the string that was typed. 
      (let ((return-string (current-line)))

	% Switch back to old window, etc.
	(=> nmode-input-window deexpose)
	(nmode-select-window old-window)

	% Restore original "message window".
	(set-message old-msg)
	return-string
	))))

(de Process-prefix ()
  (nmode-append-separated-prompt "Process-")
  (let ((ch (input-terminal-character)))
    (nmode-complete-prompt (x-char-name ch))
    (list (x-char C-!\) ch)
    ))

(define-command-prefix 'Process-prefix "Process-")

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%  Most of what follows really should gpo into MODE-DEFS.SL, if processes become
%  an accepted part of NMODE

(CompileTime (load extended-char))

(fluid '(Process-Mode
	 ))

(fluid '(Process-Command-List
	 Process-Mode-Command-List
	 ))

(setf Text-Mode
  (nmode-define-mode
   "Text"
   '((nmode-define-commands Text-Command-List)
     (nmode-define-commands Modifying-Terminal-Command-List)
     (nmode-define-commands Process-Command-List)
     (nmode-establish-mode Read-Only-Text-Mode)
     (nmode-define-normal-self-inserts)
     )))

(setf Process-Mode
  (nmode-define-mode
   "Process"
   '((nmode-define-commands Process-Command-List)
     (nmode-define-commands Process-Mode-Command-List)
     (nmode-establish-mode Read-Only-Text-Mode)
     )))

(setf Lisp-Interface-Mode
  (nmode-define-mode
   "Lisp"
   '((nmode-define-commands Rlisp-Command-List)
     (establish-lisp-parser)
     (nmode-define-commands Lisp-Command-List)
     (nmode-define-commands Process-Command-List)
     (nmode-establish-mode Text-Mode)
     )))

(de process-mode-command ()
  (buffer-set-mode nmode-current-buffer Process-Mode)
  )

% Process-Mode-Command-List - commands related to the Process interface

(setf Process-Mode-Command-List
  (list
   (cons (x-char C-k)                   'cut-line-command)
   (cons (x-char RETURN)		'execute-line-command)
   ))

% Process-Command-List - commands related to the Process interface

(setf Process-Command-List
  (list
   (cons (x-char C-!\)			'Process-prefix)
   (cons (x-chars C-!\ C)		'intrpt-process-command)
   (cons (x-chars C-!\ E)		'execute-line-command)
   (cons (x-chars C-!\ I)		'execute-from-input-window)
   (cons (x-chars C-!\ K)		'kill-process-command)
   (cons (x-chars C-!\ Q)               'send-char-immediate-command)
   (cons (x-chars C-!\ P)               'process-browser-command)
   (cons (x-chars C-!\ U)		'execute-unterminated-line-command)
   ))

(setf Basic-Command-List
  (NConc Basic-Command-List
	 (list (cons (m-x "Create Process") 'create-process-command))))

(setf Text-Command-List
  (NConc Text-Command-List
	 (list (cons (m-x "Process Mode") 'Process-mode-command))))