Artifact 3585e1b8a19543f8b4947a991fdf5b9989e13250d62488d132b6c9bcd3f23649:


%
% 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))))


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]