--- /dev/null
+#| -*-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))
+\f
+(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)
+\f
+(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)
+\f
+(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))))
+\f
+(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)))))))))
+\f
+(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))))
+\f
+(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)))
+\f
+;;;; 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))))))))
+\f
+(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
--- /dev/null
+;;; -*-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))
+\f
+(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?)
+\f
+(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))))))
+\f
+(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))))))
+\f
+;;;; 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)))))
+\f
+(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)))
+\f
+;;;; 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)))))
+\f
+;;;; 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))
+\f
+;;;; 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))
+\f
+(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)))))))))))))
+\f
+;;; 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
--- /dev/null
+#| -*-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))
+\f
+(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)
+\f
+(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"))))))))
+\f
+(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
projects / mit-scheme.git / commitdiff