From 1e6c5f66bedb88b0e4a304c6b42686e323779696 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 16 Mar 1991 00:03:58 +0000 Subject: [PATCH] Initial revision --- v7/src/edwin/comint.scm | 522 ++++++++++++++++++++++++++++++++ v7/src/edwin/process.scm | 639 +++++++++++++++++++++++++++++++++++++++ v7/src/edwin/shell.scm | 227 ++++++++++++++ 3 files changed, 1388 insertions(+) create mode 100644 v7/src/edwin/comint.scm create mode 100644 v7/src/edwin/process.scm create mode 100644 v7/src/edwin/shell.scm diff --git a/v7/src/edwin/comint.scm b/v7/src/edwin/comint.scm new file mode 100644 index 000000000..5a6f9809a --- /dev/null +++ b/v7/src/edwin/comint.scm @@ -0,0 +1,522 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comint.scm,v 1.1 1991/03/15 23:59:27 cph Exp $ + +Copyright (c) 1991 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. + +NOTE: Parts of this program (Edwin) were created by translation from +corresponding parts of GNU Emacs. Users should be aware that the GNU +GENERAL PUBLIC LICENSE may apply to these parts. A copy of that +license should have been included along with this file. |# + +;;;; Command interpreter subprocess control +;;; Translated from "comint.el", by Olin Shivers. + +(declare (usual-integrations)) + +(define (make-comint mode name program . switches) + (let ((buffer (find-or-create-buffer (string-append "*" name "*")))) + (if (let ((process (get-buffer-process buffer))) + (or (not process) + (not (process-runnable? process)))) + (begin + (set-buffer-major-mode! buffer mode) + (apply comint-exec buffer name program switches))) + buffer)) + +(define (comint-exec buffer name program switches) + ;; Get rid of any old processes. + (for-each delete-process (buffer-processes buffer)) + (set-buffer-point! buffer (buffer-end buffer)) + (define-variable-local-value! buffer + (ref-variable-object comint-program-name) + program) + (start-process name + buffer + (process-environment-bind scheme-subprocess-environment + (string-append + "TERMCAP=emacs:co#" + (number->string + (screen-x-size (selected-screen))) + ":tc=unknown") + "TERM=emacs" + "EMACS=t") + program + switches)) + +(define-variable-per-buffer comint-prompt-regexp + "Regexp to recognise prompts in the inferior process. +Defaults to \"^\", the null string at BOL. + +Good choices: + Canonical Lisp: \"^[^> ]*>+:? *\" (Lucid, franz, kcl, T, cscheme, oaklisp) + Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\" + franz: \"^\\(->\\|<[0-9]*>:\\) *\" + kcl: \"^>+ *\" + shell: \"^[^#$%>]*[#$%>] *\" + T: \"^>+ *\" + +This is a good thing to set in mode hooks." + "^") + +(define-variable-per-buffer comint-input-ring-size + "Size of input history ring." + 30) + +(define-variable comint-last-input-end "" false) +(define-variable comint-input-ring "" false) + +(define-variable comint-program-name + "File name of program that is running in this buffer." + false) + +(define-major-mode comint fundamental "Comint" + "Major mode for interacting with an inferior interpreter. +Interpreter name is same as buffer name, sans the asterisks. +Return at end of buffer sends line as input. +Return not at end copies rest of line to end and sends it. + +This mode is typically customised to create inferior-lisp-mode, +shell-mode, etc.. This can be done by setting the hooks +comint-input-sentinel, comint-input-filter, and comint-get-old-input +to appropriate procedures, and the variable comint-prompt-regexp to +the appropriate regular expression. + +An input history is maintained of size comint-input-ring-size, and +can be accessed with the commands comint-next-input [\\[comint-next-input]] and +comint-previous-input [\\[comint-previous-input]]. Commands not keybound by +default are send-invisible, comint-dynamic-complete, and +comint-list-dynamic-completions. + +If you accidentally suspend your process, use \\[comint-continue-subjob] +to continue it. + +Entry to this mode runs the hooks on comint-mode-hook." + (local-set-variable! mode-line-process '(": %s")) + (local-set-variable! comint-input-ring + (make-ring (ref-variable comint-input-ring-size))) + (local-set-variable! comint-last-input-end + (mark-right-inserting-copy + (buffer-end (current-buffer)))) + (local-set-variable! comint-last-input-match false) + (event-distributor/invoke! (ref-variable comint-mode-hook))) + +(define-variable comint-mode-hook + "An event distributor that is invoked when entering Comint mode." + (make-event-distributor)) + +(define-key 'comint #\C-a 'comint-bol) +(define-key 'comint #\C-d 'comint-delchar-or-maybe-eof) +(define-key 'comint #\C-m 'comint-send-input) + +(define-key 'comint #\M-p 'comint-previous-input) +(define-key 'comint #\M-n 'comint-next-input) +(define-key 'comint #\M-s 'comint-previous-similar-input) + +(define-prefix-key 'comint #\C-c 'prefix-char) + +(define-key 'comint '(#\C-c #\C-c) 'comint-interrupt-subjob) +(define-key 'comint '(#\C-c #\C-f) 'comint-continue-subjob) +(define-key 'comint '(#\C-c #\C-l) 'comint-show-output) +(define-key 'comint '(#\C-c #\C-o) 'comint-flush-output) +(define-key 'comint '(#\C-c #\C-r) 'comint-history-search-backward) +(define-key 'comint '(#\C-c #\C-s) 'comint-history-search-forward) +(define-key 'comint '(#\C-c #\C-u) 'comint-kill-input) +(define-key 'comint '(#\C-c #\C-w) 'backward-kill-word) +(define-key 'comint '(#\C-c #\C-z) 'comint-stop-subjob) +(define-key 'comint '(#\C-c #\C-\\) 'comint-quit-subjob) + +(define-command comint-send-input + "Send input to process. +After the process output mark, sends all text from the process mark to +point as input to the process. Before the process output mark, calls +value of variable comint-get-old-input to retrieve old input, copies +it to the end of the buffer, and sends it. A terminal newline is also +inserted into the buffer and sent to the process. In either case, +value of variable comint-input-sentinel is called on the input before +sending it. The input is entered into the input history ring, if +value of variable comint-input-filter returns non-false when called on +the input." + () + (lambda () (comint-send-input "\n" false))) + +(define (comint-send-input terminator delete?) + (let ((process (current-process))) + (let ((mark (process-mark process))) + (let ((string + (let ((point (current-point))) + (if (mark>= point mark) + (let ((end (group-end point))) + (set-current-point! end) + (extract-string mark end)) + (let ((string ((ref-variable comint-get-old-input)))) + (delete-string mark (group-end mark)) + (set-current-point! mark) + (insert-string string mark) + string))))) + (let ((point (current-point))) + (move-mark-to! (ref-variable comint-last-input-end) point) + (if ((ref-variable comint-input-filter) string) + (ring-push! (ref-variable comint-input-ring) string)) + ((ref-variable comint-input-sentinel) string) + (if delete? + (delete-string mark point) + (insert-newline point)) + (move-mark-to! mark point) + (process-send-string process (string-append string terminator))))))) + +(define-variable-per-buffer comint-get-old-input + "Procedure that submits old text in comint mode. +This procedure is called when return is typed while the point is in old text. +It returns the text to be submitted as process input. The default is +comint-get-old-input-default, which grabs the current line and strips off +leading text matching comint-prompt-regexp." + (lambda () + (let ((mark (comint-line-start (current-point)))) + (extract-string mark (line-end mark 0))))) + +(define-variable-per-buffer comint-input-sentinel + "Called on each input submitted to comint mode process by comint-send-input. +Thus it can, for instance, track cd/pushd/popd commands issued to the shell." + (lambda (string) + string + unspecific)) + +(define-variable-per-buffer comint-input-filter + "Predicate for filtering additions to input history. +Only inputs answering true to this procedure are saved on the input +history list. Default is to save anything that isn't all whitespace." + (lambda (string) + (not (re-match-string-forward "\\`\\s *\\'" string)))) + +(define-command comint-previous-input + "Cycle backwards through input history." + "*p" + (lambda (argument) + (let ((point (current-point)) + (ring (ref-variable comint-input-ring))) + (let ((size (+ (ring-size ring) 1))) + (let ((index + (modulo (+ argument + (command-message-receive comint-input-ring-tag + (lambda (index) + (delete-string (current-mark) point) + index) + (lambda () + (push-current-mark! point) + (cond ((positive? argument) 0) + ((negative? argument) 2) + (else 1))))) + size))) + (message (number->string index)) + (if (positive? index) + (insert-string (ring-ref ring (- index 1)) point)) + (set-command-message! comint-input-ring-tag index)))))) + +(define comint-input-ring-tag + '(COMINT-INPUT-RING)) + +(define-command comint-next-input + "Cycle forwards through input history." + "*p" + (lambda (argument) + ((ref-command comint-previous-input) (- argument)))) + +(define-variable comint-last-input-match "" false) + +(define-command comint-history-search-backward + "Search backwards through the input history for a matching substring." + (lambda () + (list (prompt-for-string "History search backward" + (ref-variable comint-last-input-match)))) + (lambda (string) + (comint-history-search string true))) + +(define-command comint-history-search-forward + "Search forwards through the input history for a matching substring." + (lambda () + (list (prompt-for-string "History search forward" + (ref-variable comint-last-input-match)))) + (lambda (string) + (comint-history-search string false))) + +(define (comint-history-search string backward?) + (let ((ring (ref-variable comint-input-ring)) + (regexp (re-quote-string string))) + (let ((size (+ (ring-size ring) 1))) + (let ((start + (command-message-receive comint-input-ring-tag + (lambda (index) index) + (lambda () (if backward? 0 size))))) + (let loop ((index start)) + (let ((index (+ index (if backward? 1 -1)))) + (cond ((if backward? (>= index size) (< index 0)) + (set-command-message! comint-input-ring-tag start) + (editor-failure "Not found")) + ((re-search-string-forward regexp + (ring-ref ring (- index 1))) + (set-variable! comint-last-input-match string) + ((ref-command comint-previous-input) (- index start))) + (else + (loop index))))))))) + +(define-command comint-previous-similar-input + "Reenter the last input that matches the string typed so far. +If repeated successively, older inputs are reentered. +With negative arg, newer inputs are reentered." + "p" + (lambda (argument) + (let ((tag '(COMINT-PREVIOUS-SIMILAR-INPUT)) + (mark (process-mark (current-process))) + (point (current-point)) + (ring (ref-variable comint-input-ring))) + (if (mark< point mark) + (editor-error "Not after process mark")) + (let ((do-it + (lambda (index* prefix) + (let ((size (ring-size ring))) + (let loop ((index index*)) + (let ((index (+ index (if (negative? argument) -1 1)))) + (if (or (negative? index) + (>= index size)) + (begin + (editor-failure "Not found") + (if (not (= index* -1)) + (set-command-message! tag index* prefix))) + (let ((string (ring-ref ring index))) + (if (string-prefix? prefix string) + (begin + (delete-string mark point) + (insert-string string point) + (set-command-message! tag index prefix)) + (loop index)))))))))) + (command-message-receive tag + do-it + (lambda () (do-it -1 (extract-string mark point)))))))) + +(define-command comint-kill-input + "Kill all text from last stuff output by interpreter to point." + () + (lambda () + (let ((mark (process-mark (current-process))) + (point (current-point))) + (if (mark>= point mark) + (kill-string mark point) + (editor-error "Nothing to kill"))))) + +(define-command comint-flush-output + "Kill all output from interpreter since last input." + () + (lambda () + (let ((mark + (mark-permanent! (line-start (process-mark (current-process)) 0)))) + (delete-string (mark1+ (ref-variable comint-last-input-end) 'LIMIT) mark) + (insert-string "*** output flushed ***\n" mark)))) + +(define-command comint-show-output + "Start display of the current window at line preceding start of last output. +\"Last output\" is considered to start at the line following the last command +entered to the process." + () + (lambda () + (let ((mark (line-start (ref-variable comint-last-input-end) 0))) + (set-current-point! (comint-line-start mark)) + (set-window-start-mark! (current-window) mark true)))) + +(define-command comint-bol + "Goes to the beginning of line, then skips past the prompt, if any. +With argument, don't skip the prompt -- go straight to column 0. + +The prompt skip is done by skipping text matching the regular expression +comint-prompt-regexp." + "P" + (lambda (argument) + (set-current-point! + (if argument + (line-start (current-point) 0) + (comint-line-start (current-point)))))) + +(define (comint-line-start mark) + (let ((start (line-start mark 0))) + (let ((mark + (re-match-forward (ref-variable comint-prompt-regexp) + start + (group-end mark)))) + (if (mark<= mark (line-end start 0)) + mark + start)))) + +(define-command comint-delchar-or-maybe-eof + "If at end of buffer, send EOF to the current subprocess. +If not at end of buffer, just like \\[delete-char]." + "p" + (lambda (argument) + (if (group-end? (current-point)) + (process-send-eof (current-process)) + ((ref-command delete-char) argument)))) + +(define-command comint-interrupt-subjob + "Sent an interrupt signal to the current subprocess. +If the process-connection-type is via ptys, the signal is sent to the current +process group of the pseudoterminal which Edwin is using to communicate with +the subprocess. If the process is a job-control shell, this means the +shell's current subjob. If the process connection is via pipes, the signal is +sent to the immediate subprocess." + () + (lambda () (interrupt-process (current-process) true))) + +(define-command comint-kill-subjob + "Send a kill signal to the current subprocess. +See comint-interrupt-subjob for a description of \"current subprocess\"." + () + (lambda () (kill-process (current-process) true))) + +(define-command comint-quit-subjob + "Send a quit signal to the current subprocess. +See comint-interrupt-subjob for a description of \"current subprocess\"." + () + (lambda () (quit-process (current-process) true))) + +(define-command comint-stop-subjob + "Stop the current subprocess. +See comint-interrupt-subjob for a description of \"current subprocess\". + +WARNING: if there is no current subjob, you can end up suspending +the top-level process running in the buffer. If you accidentally do +this, use \\[comint-continue-subjob] to resume the process. (This is not a +problem with most shells, since they ignore this signal.)" + () + (lambda () (stop-process (current-process) true))) + +(define-command comint-continue-subjob + "Send a continue signal to current subprocess. +See comint-interrupt-subjob for a description of \"current subprocess\". +Useful if you accidentally suspend the top-level process." + () + (lambda () (continue-process (current-process) true))) + +;;;; Filename Completion + +(define-command comint-replace-by-expanded-filename + "Replace the filename at point with its expanded, canonicalised completion. +\"Expanded\" means environment variables (e.g., $HOME) and ~'s are +replaced with the corresponding directories. \"Canonicalised\" means .. +and . are removed, and the filename is made absolute instead of relative. +See also \\[comint-dynamic-complete]." + () + (lambda () + (let ((region (comint-current-filename-region))) + (let ((filename (region->string region))) + (set-current-point! (region-end region)) + (comint-filename-complete + (merge-pathnames (->pathname filename) + (buffer-default-directory (current-buffer))) + filename + (lambda (filename*) + (region-delete! region) + (insert-string filename* (region-start region)))))))) + +(define-command comint-dynamic-complete + "Complete the filename at point. +This function is similar to \\[comint-replace-by-expanded-filename], except +that it won't change parts of the filename already entered in the buffer; +it just adds completion characters to the end of the filename." + () + (lambda () + (let ((region (comint-current-filename-region))) + (let ((pathname + (merge-pathnames (->pathname (region->string region)) + (buffer-default-directory (current-buffer))))) + (let ((filename (pathname->string pathname))) + (set-current-point! (region-end region)) + (comint-filename-complete + pathname + filename + (lambda (filename*) + (insert-substring filename* + (string-length filename) + (string-length filename*) + (region-end region))))))))) + +(define-command comint-dynamic-list-completions + "List all possible completions of the filename at point." + () + (lambda () + (comint-list-filename-completions + (lambda () + (filename-completions-list + (merge-pathnames + (->pathname (region->string (comint-current-filename-region))) + (buffer-default-directory (current-buffer)))))))) + +(define (comint-current-filename-region) + (let ((point (current-point)) + (chars "~/A-Za-z0-9---_.$#,")) + (let ((start + (skip-chars-backward chars + point + (comint-line-start point) + 'LIMIT))) + (let ((end + (skip-chars-forward chars start (line-end start 0) 'LIMIT))) + (and (mark< start end) + (make-region start end)))))) + +(define (comint-filename-complete pathname filename insert-completion) + (filename-complete-string pathname + (lambda (filename*) + (if (string=? filename filename*) + (message "Sole completion") + (insert-completion filename*))) + (lambda (filename* list-completions) + (if (string=? filename filename*) + (if (ref-variable completion-auto-help) + (comint-list-filename-completions list-completions) + (message "Next char not unique")) + (insert-completion filename*))) + (lambda () + (editor-failure "No completions")))) + +(define (comint-list-filename-completions list-completions) + (message "Making completion list...") + (let ((completions (list-completions))) + (clear-message) + (if (null? completions) + (editor-failure "No completions") + (cleanup-pop-up-buffers + (lambda () + (write-completions-list completions) + (message "Hit space to flush.") + (reset-command-prompt!) + (let ((char (keyboard-peek-char))) + (if (char=? #\space char) + (keyboard-read-char))) + (clear-message)))))) \ No newline at end of file diff --git a/v7/src/edwin/process.scm b/v7/src/edwin/process.scm new file mode 100644 index 000000000..6342df7b0 --- /dev/null +++ b/v7/src/edwin/process.scm @@ -0,0 +1,639 @@ +;;; -*-Scheme-*- +;;; +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/process.scm,v 1.1 1991/03/16 00:03:58 cph Exp $ +;;; +;;; Copyright (c) 1991 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with +;;; the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; +;;; NOTE: Parts of this program (Edwin) were created by translation +;;; from corresponding parts of GNU Emacs. Users should be aware that +;;; the GNU GENERAL PUBLIC LICENSE may apply to these parts. A copy +;;; of that license should have been included along with this file. +;;; + +;;;; Subprocess Support + +(declare (usual-integrations)) + +(define (initialize-processes!) + (set! edwin-processes '()) + (set-variable! exec-path + (parse-path-string (get-environment-variable "PATH")))) + +(define edwin-processes) + +(define-variable exec-path + "List of directories to search programs to run in subprocesses. +Each element is a string (directory name) or #F (try default directory)." + '() + (lambda (exec-path) + (and (list? exec-path) + (for-all? exec-path + (lambda (element) + (or (not element) + (pathname? element))))))) + +(define-variable process-connection-type + "Control type of device used to communicate with subprocesses. +Values are #f to use a pipe, #t for a pty (or pipe if ptys not supported). +Value takes effect when `start-process' is called." + true + boolean?) + +(define-variable delete-exited-processes + "True means delete processes immediately when they exit. +False means don't delete them until \\[list-processes] is run." + true + boolean?) + +(define-structure (process + (constructor %make-process (subprocess name %buffer))) + (subprocess false read-only true) + (name false read-only true) + %buffer + (mark false) + (filter false) + (sentinel false) + (kill-without-query false) + (notification-tick (cons false false))) + +(define-integrable (process-arguments process) + (subprocess-arguments (process-subprocess process))) + +(define-integrable (process-input-channel process) + (subprocess-input-channel (process-subprocess process))) + +(define-integrable (process-output-channel process) + (subprocess-output-channel (process-subprocess process))) + +(define-integrable (process-status-tick process) + (subprocess-status-tick (process-subprocess process))) + +(define-integrable (process-exit-reason process) + (subprocess-exit-reason (process-subprocess process))) + +(define (process-status process) + (status->emacs-status (subprocess-status (process-subprocess process)))) + +(define (status->emacs-status status) + (case status + ((RUNNING) 'RUN) + ((STOPPED) 'STOP) + ((EXITED) 'EXIT) + ((SIGNALLED) 'SIGNAL) + (else status))) + +(define (process-runnable? process) + (let ((status (subprocess-status (process-subprocess process)))) + (or (eq? 'RUNNING status) + (eq? 'STOPPED status)))) + +(define-integrable (process-buffer process) + (process-%buffer process)) + +(define (set-process-buffer! process buffer) + (without-interrupts + (lambda () + (if (not (eq? buffer (process-buffer process))) + (begin + (set-process-%buffer! process buffer) + (update-process-mark! process)))))) + +(define (update-process-mark! process) + (set-process-mark! + process + (let ((buffer (process-buffer process))) + (and buffer + (mark-right-inserting-copy (buffer-end buffer)))))) + +(define (start-process name buffer environment program . arguments) + (let ((directory (buffer-default-directory buffer))) + (let ((make-subprocess + (let ((filename (find-program program directory)) + (arguments (list->vector (cons program arguments)))) + (if (and (eq? true (ref-variable process-connection-type)) + ((ucode-primitive have-ptys? 0))) + (lambda () + (start-pty-subprocess filename arguments environment)) + (lambda () + (start-pipe-subprocess filename arguments environment)))))) + ;; Calling WITH-WORKING-DIRECTORY-PATHNAME is a kludge -- + ;; there's no other way to specify the working directory of the + ;; subprocess. The subprocess abstraction should be fixed to + ;; allow this. + (with-working-directory-pathname directory + (lambda () + (without-interrupts + (lambda () + (let ((subprocess (make-subprocess))) + (let ((channel (subprocess-input-channel subprocess))) + (if channel + (begin + (channel-nonblocking channel) + (channel-register channel)))) + (let ((process + (%make-process + subprocess + (do ((n 2 (+ n 1)) + (name* name + (string-append name + "<" (number->string n) ">"))) + ((not (get-process-by-name name*)) name*)) + buffer))) + (update-process-mark! process) + (subprocess-put! subprocess 'EDWIN-PROCESS process) + (set! edwin-processes (cons process edwin-processes)) + process))))))))) + +(define (delete-process process) + (let ((subprocess (process-subprocess process))) + (without-interrupts + (lambda () + (set! edwin-processes (delq! process edwin-processes)) + (subprocess-remove! subprocess 'EDWIN-PROCESS) + (if (process-runnable? process) + (begin + (subprocess-kill subprocess) + (perform-status-notification process 'SIGNALLED false))) + (let ((channel (subprocess-input-channel subprocess))) + (if channel + (channel-unregister channel))) + (subprocess-delete subprocess))))) + +(define (get-process-by-name name) + (let loop ((processes edwin-processes)) + (cond ((null? processes) false) + ((eq? name (process-name (car processes))) (car processes)) + (else (loop (cdr processes)))))) + +(define (get-buffer-process buffer) + (let loop ((processes edwin-processes)) + (cond ((null? processes) false) + ((eq? buffer (process-buffer (car processes))) (car processes)) + (else (loop (cdr processes)))))) + +(define (buffer-processes buffer) + (let loop ((processes edwin-processes)) + (cond ((null? processes) + '()) + ((eq? buffer (process-buffer (car processes))) + (cons (car processes) (loop (cdr processes)))) + (else + (loop (cdr processes)))))) + +;;;; Input and Output + +(define (process-send-eof process) + (process-send-char process #\EOT)) + +(define (process-send-substring process string start end) + (channel-write-block (process-output-channel process) string start end)) + +(define (process-send-string process string) + (channel-write-string-block (process-output-channel process) string)) + +(define (process-send-char process char) + (channel-write-char-block (process-output-channel process) char)) + +(define (accept-process-output) + (without-interrupts + (lambda () + (let loop ((processes edwin-processes) (output? false)) + (if (null? processes) + output? + (loop (cdr processes) + (if (poll-process-for-output (car processes)) + true + output?))))))) + +(define (poll-process-for-output process) + (let ((channel (process-input-channel process)) + (buffer (make-string 512))) + (and (channel-open? channel) + (let ((n (channel-read channel buffer 0 512))) + (and n + (if (positive? n) + (output-substring process buffer n) + (begin + (channel-close channel) + false))))))) + +(define (notify-process-status-changes) + (without-interrupts + (lambda () + (let ((tick (subprocess-global-status-tick))) + (and (not (eq? tick global-notification-tick)) + (begin + (set! global-notification-tick tick) + (let loop ((processes edwin-processes) (output? false)) + (if (null? processes) + output? + (loop (cdr processes) + (if (poll-process-for-status-change (car processes)) + true + output?)))))))))) + +(define global-notification-tick + (cons false false)) + +(define (poll-process-for-status-change process) + (let ((status (subprocess-status (process-subprocess process)))) + (and (not (eq? (process-notification-tick process) + (process-status-tick process))) + (perform-status-notification process + status + (process-exit-reason process))))) + +(define (perform-status-notification process status reason) + (set-process-notification-tick! process (process-status-tick process)) + (let ((value + (cond ((process-sentinel process) + => + (lambda (sentinel) + (sentinel process status reason) + true)) + ((eq? status 'RUNNING) + false) + (else + (let ((message + (string-append "\nProcess " + (process-name process) + " " + (process-status-message + (status->emacs-status status) + reason) + "\n"))) + (output-substring process + message + (string-length message))))))) + (if (and (or (eq? 'EXITED status) + (eq? 'SIGNALLED status)) + (ref-variable delete-exited-processes)) + (delete-process process)) + value)) + +(define (process-status-message status reason) + (let ((message-with-reason + (lambda (prefix connective) + (if reason + (string-append prefix + (if connective (string-append " " connective) "") + " " + (number->string reason)) + prefix)))) + (case status + ((RUN) "running") + ((STOP) (message-with-reason "stopped by signal" false)) + ((EXIT) + (if (zero? reason) + "finished" + (message-with-reason "exited abnormally" "with code"))) + ((SIGNAL) (message-with-reason "terminated by signal" false)) + (else (error "illegal process status" status))))) + +(define (output-substring process string length) + (cond ((process-filter process) + => + (lambda (filter) + (filter string 0 length) + true)) + ((process-mark process) + => + (lambda (mark) + (let ((index (mark-index mark))) + (group-insert-substring! (mark-group mark) index string 0 length) + (set-mark-index! mark (+ index length))) + true)) + (else false))) + +;;;; Signals + +(define (signal-process process signal group?) + (let ((process (process-subprocess process))) + (let ((pty-master (and group? (subprocess-pty-master process)))) + (if pty-master + (pty-master-send-signal pty-master signal) + (subprocess-signal process signal))))) + +(define (interrupt-process process group?) + (let ((process (process-subprocess process))) + (let ((pty-master (and group? (subprocess-pty-master process)))) + (if pty-master + (pty-master-interrupt pty-master) + (subprocess-interrupt process))))) + +(define (quit-process process group?) + (let ((process (process-subprocess process))) + (let ((pty-master (and group? (subprocess-pty-master process)))) + (if pty-master + (pty-master-quit pty-master) + (subprocess-quit process))))) + +(define (hangup-process process group?) + (let ((process (process-subprocess process))) + (let ((pty-master (and group? (subprocess-pty-master process)))) + (if pty-master + (pty-master-hangup pty-master) + (subprocess-hangup process))))) + +(define (stop-process process group?) + (let ((process (process-subprocess process))) + (let ((pty-master (and group? (subprocess-pty-master process)))) + (if pty-master + (pty-master-stop pty-master) + (subprocess-stop process))))) + +(define (continue-process process group?) + (let ((process (process-subprocess process))) + (let ((pty-master (and group? (subprocess-pty-master process)))) + (if pty-master + (pty-master-continue pty-master) + (subprocess-continue-background process))))) + +(define (kill-process process group?) + (let ((process (process-subprocess process))) + (let ((pty-master (and group? (subprocess-pty-master process)))) + (if pty-master + (pty-master-kill pty-master) + (subprocess-kill process))))) + +;;;; LIST-PROCESSES + +(define-command list-processes + "Display a list of all processes. +\(Any processes listed as exited or signalled are actually eliminated +after the listing is made.)" + () + (lambda () + (let ((buffer (temporary-buffer "*Process List*"))) + (let ((point (buffer-point buffer))) + (let ((write-line + (lambda (process status buffer command) + (insert-string process point) + (insert-horizontal-space 13 point) + (insert-string status point) + (insert-horizontal-space 24 point) + (insert-string buffer point) + (insert-horizontal-space 40 point) + (insert-string command point) + (insert-newline point)))) + (write-line "Process" "Status" "Buffer" "Command") + (write-line "-------" "------" "------" "-------") + (do ((processes edwin-processes (cdr processes))) + ((null? processes)) + (let ((process (car processes))) + (write-line (or (process-name process) "") + (let ((status (process-status process))) + (let ((name (symbol->string status))) + (if (or (eq? 'EXIT status) + (eq? 'SIGNAL status)) + (let ((reason (process-exit-reason process))) + (delete-process process) + (if (and (eq? 'EXIT status) + (zero? reason)) + name + (string-append + name + " " + (number->string reason)))) + name))) + (let ((buffer (process-buffer process))) + (cond ((not buffer) "(none)") + ((buffer-alive? buffer) (buffer-name buffer)) + (else "(killed)"))) + (process-arguments->string + (process-arguments process))))))) + (set-buffer-point! buffer (buffer-start buffer)) + (buffer-not-modified! buffer) + (pop-up-buffer buffer false)))) + +(define (process-arguments->string arguments) + (if (zero? (vector-length arguments)) + "" + (apply string-append + (let loop ((arguments (vector->list arguments))) + (cons (car arguments) + (if (null? (cdr arguments)) + '() + (cons " " (loop (cdr arguments))))))))) + +(define (process-list) + (list-copy edwin-processes)) + +;;;; Synchronous Subprocesses + +(define (shell-command command output-mark) + (let ((process + (start-pipe-subprocess "/bin/sh" (vector "sh" "-c" command) false))) + (channel-close (subprocess-output-channel process)) + (let ((output-channel (subprocess-input-channel process))) + (channel-nonblocking output-channel) + (let ((copy-output + (let ((buffer (make-string 512))) + (lambda () + (let loop () + (let ((n (channel-read output-channel buffer 0 512))) + (if (and n (positive? n)) + (begin + (insert-substring buffer 0 n output-mark) + (loop))))))))) + (let loop () + (copy-output) + (let ((status (subprocess-status process))) + (if (eq? status 'RUNNING) + (loop) + (begin + (channel-blocking output-channel) + (copy-output) + (process-termination-message process + status + output-mark))))))))) + +(define (process-termination-message process status output-mark) + (let ((reason (subprocess-exit-reason process))) + (let ((abnormal-termination + (lambda (message) + (guarantee-newlines 2 output-mark) + (insert-string "Process " output-mark) + (insert-string message output-mark) + (insert-string " " output-mark) + (insert-string (number->string reason) output-mark) + (insert-string "." output-mark) + (insert-newline output-mark)))) + (case status + ((STOPPED) + (abnormal-termination "stopped with signal") + (subprocess-kill process) + (subprocess-wait process)) + ((SIGNALLED) + (abnormal-termination "terminated with signal")) + ((EXITED) + (if (not (eqv? 0 reason)) + (abnormal-termination "exited abnormally with code")))))) + (subprocess-delete process)) + +(define (shell-command-region command output-mark input-region) + (let ((process + (start-pipe-subprocess "/bin/sh" (vector "sh" "-c" command) false)) + (group (region-group input-region)) + (start-index (region-start-index input-region)) + (end-index (region-end-index input-region))) + (let ((input-channel (subprocess-output-channel process)) + (output-channel (subprocess-input-channel process))) + (channel-nonblocking input-channel) + (channel-nonblocking output-channel) + (let ((copy-output + (let ((buffer (make-string 512))) + (lambda () + (let loop () + (let ((n (channel-read output-channel buffer 0 512))) + (if (and n (positive? n)) + (begin + (insert-substring buffer 0 n output-mark) + (loop))))))))) + (call-with-current-continuation + (lambda (continuation) + (bind-condition-handler (list condition-type:system-call-error) + (lambda (condition) + (if (and (eq? 'WRITE + (access-condition condition 'SYSTEM-CALL)) + (eq? 'BROKEN-PIPE + (access-condition condition 'ERROR-TYPE))) + (begin + (channel-blocking output-channel) + (copy-output) + (guarantee-newlines 2 output-mark) + (insert-string "broken pipe" output-mark) + (insert-newline output-mark) + (continuation + (process-termination-message process + (subprocess-wait process) + output-mark))))) + (lambda () + (let loop () + (if (< start-index end-index) + (let ((index (min (+ start-index 512) end-index))) + (let ((buffer + (group-extract-string group + start-index + index))) + (let ((n + (channel-write input-channel + buffer + 0 + (string-length buffer)))) + (if n + (begin + (set! start-index (+ start-index n)) + (if (= start-index end-index) + (channel-close input-channel)))))))) + (copy-output) + (let ((status (subprocess-status process))) + (if (eq? status 'RUNNING) + (loop) + (begin + (channel-blocking output-channel) + (copy-output) + (process-termination-message process + status + output-mark))))))))))))) + +;;; These procedures are not specific to the process abstraction. + +(define (find-program program default-directory) + (let ((program (->pathname program)) + (default-directory (pathname->absolute-pathname default-directory)) + (lose (lambda () (error "Can't find program:" program)))) + (if (pathname-absolute? program) + (begin + (if (not (unix/file-access program 1)) (lose)) + (pathname->string program)) + (let loop ((path (ref-variable exec-path))) + (if (null? path) (lose)) + (let ((pathname + (merge-pathnames + program + (cond ((not (car path)) default-directory) + ((pathname-absolute? (car path)) (car path)) + (else + (merge-pathnames (car path) default-directory)))))) + (if (unix/file-access pathname 1) + (pathname->string pathname) + (loop (cdr path)))))))) + +(define (parse-path-string string) + (let ((end (string-length string)) + (substring + (lambda (string start end) + (pathname-as-directory + (string->pathname (substring string start end)))))) + (let loop ((start 0)) + (if (< start end) + (let ((index (substring-find-next-char string start end #\:))) + (if index + (cons (if (= index start) + false + (substring string start index)) + (loop (+ index 1))) + (list (substring string start end)))) + '())))) + +(define (process-environment-bind environment . bindings) + (let ((bindings* (vector->list environment))) + (for-each (lambda (binding) + (let ((b + (find-environment-variable + (environment-binding-name binding) + bindings*))) + (if b + (set-car! b binding) + (begin + (set! bindings* (cons binding bindings*)) + unspecific)))) + bindings) + (list->vector bindings*))) + +(define (environment-binding-name binding) + (let ((index (string-find-next-char binding #\=))) + (if (not index) + binding + (string-head binding index)))) + +(define (find-environment-variable name bindings) + (let ((prefix (string-append name "="))) + (let loop ((bindings bindings)) + (and (not (null? bindings)) + (if (string-prefix? prefix (car bindings)) + bindings + (loop (cdr bindings))))))) \ No newline at end of file diff --git a/v7/src/edwin/shell.scm b/v7/src/edwin/shell.scm new file mode 100644 index 000000000..666fe9789 --- /dev/null +++ b/v7/src/edwin/shell.scm @@ -0,0 +1,227 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/shell.scm,v 1.1 1991/03/16 00:00:00 cph Exp $ + +Copyright (c) 1991 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. + +NOTE: Parts of this program (Edwin) were created by translation from +corresponding parts of GNU Emacs. Users should be aware that the GNU +GENERAL PUBLIC LICENSE may apply to these parts. A copy of that +license should have been included along with this file. |# + +;;;; Shell subprocess in a buffer +;;; Translated from "cmushell.el", by Olin Shivers. + +(declare (usual-integrations)) + +(define-variable shell-prompt-pattern + "Regexp to match prompts in the inferior shell." + "^[^#$>]*[#$>] *") + +(define-variable explicit-shell-file-name + "If not #F, file name to use for explicitly requested inferior shell." + false) + +(define-variable explicit-csh-args + "Args passed to inferior shell by M-x shell, if the shell is csh. +Value is a list of strings." + (if (string=? microcode-id/operating-system-variant "HP-UX") + ;; -T persuades HP's csh not to think it is smarter + ;; than us about what terminal modes to use. + '("-i" "-T") + '("-i"))) + +(define-major-mode shell comint "Shell" + "Major mode for interacting with an inferior shell. +Return after the end of the process' output sends the text from the + end of process to the end of the current line. +Return before end of process output copies rest of line to end (skipping + the prompt) and sends it. + +If you accidentally suspend your process, use \\[comint-continue-subjob] +to continue it. + +cd, pushd and popd commands given to the shell are watched to keep +this buffer's default directory the same as the shell's working directory. +\\[shell-resync-dirs] queries the shell and resyncs Edwin's idea of what the + current directory stack is. +\\[shell-dirtrack-toggle] turns directory tracking on and off. + +Customisation: Entry to this mode runs the hooks on comint-mode-hook and +shell-mode-hook (in that order). + +Variables shell-cd-regexp, shell-pushd-regexp and shell-popd-regexp are used +to match their respective commands." + (set-variable! comint-prompt-regexp (ref-variable shell-prompt-pattern)) + (set-variable! comint-input-sentinel shell-directory-tracker) + (local-set-variable! shell-dirstack '()) + (local-set-variable! shell-dirtrack? true) + (event-distributor/invoke! (ref-variable shell-mode-hook))) + +(define-variable shell-mode-hook + "An event distributor that is invoked when entering Shell mode." + (make-event-distributor)) + +(define-key 'shell #\tab 'comint-dynamic-complete) +(define-key 'shell #\M-? 'comint-dynamic-list-completions) + +(define-command shell + "Run an inferior shell, with I/O through buffer *shell*. +If buffer exists but shell process is not running, make new shell. +If buffer exists and shell process is running, just switch to buffer *shell*. + +The shell to use comes from the first non-#f variable found from these: +explicit-shell-file-name in Edwin, ESHELL in the environment or SHELL in the +environment. If none is found, /bin/sh is used. + +The buffer is put in Shell mode, giving commands for sending input +and controlling the subjobs of the shell. + +The shell file name (sans directories) is used to make a symbol name +such as `explicit-csh-arguments'. If that symbol is a variable, +its value is used as a list of arguments when invoking the shell. +Otherwise, one argument `-i' is passed to the shell." + () + (lambda () + (select-buffer + (let ((program + (or (ref-variable explicit-shell-file-name) + ((ucode-primitive get-environment-variable) "ESHELL") + ((ucode-primitive get-environment-variable) "SHELL") + "/bin/sh"))) + (apply make-comint + (ref-mode-object shell) + "shell" + program + (let ((variable + (string-table-get editor-variables + (string-append "explicit-" + (pathname-name-string + (->pathname program)) + "-args")))) + (if variable + (variable-value variable) + '("-i")))))))) + +(define-variable shell-popd-regexp + "Regexp to match subshell commands equivalent to popd." + "popd") + +(define-variable shell-pushd-regexp + "Regexp to match subshell commands equivalent to pushd." + "pushd") + +(define-variable shell-cd-regexp + "Regexp to match subshell commands equivalent to cd." + "cd") + +(define-variable shell-dirstack-query + "Command used by shell-resync-dirlist to query shell." + "dirs") + +(define-variable shell-dirstack + "List of directories saved by pushd in this buffer's shell." + '()) + +(define-variable shell-dirtrack? "" false) + +(define (shell-directory-tracker string) + (if (ref-variable shell-dirtrack?) + (let ((start (re-match-string-forward "^\\s *" string)) + (end (string-length string))) + (let ((try + (let ((match + (lambda (regexp start) + (re-match-substring-forward regexp + string start end)))) + (lambda (command) + (let ((eoc (match command start))) + (cond ((not eoc) + false) + ((match "\\s *\\(\;\\|$\\)" eoc) + "") + ((match "\\s +\\([^ \t\;]+\\)\\s *\\(\;\\|$\\)" eoc) + (substring string + (re-match-start-index 1) + (re-match-end-index 1))) + (else false))))))) + (cond ((try (ref-variable shell-cd-regexp)) + => shell-process-cd) + ((try (ref-variable shell-pushd-regexp)) + => shell-process-pushd) + ((try (ref-variable shell-popd-regexp)) + => shell-process-popd)))))) + +(define (shell-process-popd filename) + filename + unspecific) + +(define (shell-process-pushd filename) + filename + unspecific) + +(define (shell-process-cd filename) + (call-with-current-continuation + (lambda (continuation) + (bind-condition-handler (list condition-type:editor-error) + (lambda (condition) + (apply message (editor-error-strings condition)) + (continuation unspecific)) + (lambda () + (set-default-directory + (if (string-null? filename) + (home-directory-pathname) + filename)))))) + (shell-dirstack-message)) + +(define (shell-dirstack-message) + (apply message + (let loop + ((dirs + (cons (buffer-default-directory (current-buffer)) + (ref-variable shell-dirstack)))) + (cons (os/pathname->display-string (->pathname (car dirs))) + (if (null? (cdr dirs)) + '() + (cons " " (loop (cdr dirs)))))))) + +(define-command shell-dirtrack-toggle + "Turn directory tracking on and off in a shell buffer." + "P" + (lambda (argument) + (set-variable! shell-dirtrack? + (cond ((not argument) (not (ref-variable shell-dirtrack?))) + ((positive? argument) true) + ((negative? argument) false) + (else (ref-variable shell-dirtrack?)))) + (message "Directory tracking " + (if (ref-variable shell-dirtrack?) "on" "off") + "."))) \ No newline at end of file -- 2.25.1