--- /dev/null
+#| -*-Scheme-*-
+
+$Id: doscom.scm,v 1.1 1993/02/25 02:49:43 gjr Exp $
+
+Copyright (c) 1992-1993 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 commands for DOS
+
+(declare (usual-integrations))
+\f
+(define-command shell-command
+ "Execute string COMMAND in inferior shell; display output, if any.
+Optional second arg true (prefix arg, if interactive) means
+insert output in current buffer after point (leave mark after it)."
+ "sShell command\nP"
+ (lambda (command insert-at-point?)
+ (let ((directory (buffer-default-directory (current-buffer))))
+ (if insert-at-point?
+ (begin
+ (if (buffer-read-only? (current-buffer))
+ (barf-if-read-only))
+ (let ((point (current-point)))
+ (push-current-mark! point)
+ (shell-command false point directory command))
+ ((ref-command exchange-point-and-mark)))
+ (shell-command-pop-up-output
+ (lambda (output-mark)
+ (shell-command false output-mark directory command)))))))
+
+(define-command shell-command-on-region
+ "Execute string COMMAND in inferior shell with region as input.
+Normally display output (if any) in temp buffer;
+Prefix arg means replace the region with it."
+ "r\nsShell command on region\nP"
+ (lambda (region command replace-region?)
+ (let ((directory (buffer-default-directory (current-buffer))))
+ (if replace-region?
+ (let ((point (current-point))
+ (mark (current-mark)))
+ (let ((swap? (mark< point mark))
+ (temp))
+ (unwind-protect
+ (lambda ()
+ (set! temp (temporary-buffer " *shell-output*"))
+ unspecific)
+ (lambda ()
+ (shell-command (make-region point mark)
+ (buffer-start temp)
+ directory
+ command)
+ (without-interrupts
+ (lambda ()
+ (delete-string point mark)
+ (insert-region (buffer-start temp)
+ (buffer-end temp)
+ (current-point)))))
+ (lambda ()
+ (kill-buffer temp)
+ (set! temp)
+ unspecific))
+ (if swap? ((ref-command exchange-point-and-mark)))))
+ (shell-command-pop-up-output
+ (lambda (output-mark)
+ (shell-command region output-mark directory command)))))))
+
+(define (shell-command-pop-up-output generate-output)
+ (let ((buffer (temporary-buffer "*Shell Command Output*")))
+ (let ((start (buffer-start buffer)))
+ (generate-output start)
+ (set-buffer-point! buffer start)
+ (if (mark< start (buffer-end buffer))
+ (pop-up-buffer buffer false)
+ (message "(Shell Command completed with no output)")))))
+
+(define (shell-command input-region output-mark directory command)
+ (with-real-working-directory-pathname directory
+ (lambda ()
+ (let ((core
+ (lambda (input-port)
+ (run-subprocess command
+ input-port
+ (mark->output-port output-mark)))))
+ (if input-region
+ (core (make-buffer-input-port (region-start input-region)
+ (region-end input-region)))
+ (call-with-input-file "\\dev\\nul" core))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: dosshell.scm,v 1.1 1993/02/25 02:50:59 gjr Exp $
+
+Copyright (c) 1992-1993 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. |#
+
+;;;; Pseudo Shell subprocess in a buffer
+;;; Inspired by "cmushell.el", by Olin Shivers.
+
+(declare (usual-integrations))
+\f
+(define-major-mode pseudo-shell fundamental "Pseudo Shell"
+ "Major mode for executing DOS commands.
+Return executes the current line as a DOS command.
+Output is inserted into the buffer after the command.
+There is currently no way to send input interactively to the command.
+Use \\[shell-command-on-region] to feed input to the command.
+
+cd, pushd, and popd commands are not executed as commands (they would have
+no effect) but emulated directly by Edwin.
+
+Customization: Entry to this mode runs the hook pseudo-shell-mode-hook."
+ (lambda (buffer)
+ (define-variable-local-value! buffer
+ (ref-variable-object pseudo-shell-dirstack)
+ '())
+ (define-variable-local-value! buffer
+ (ref-variable-object pseudo-shell-dirtrack?)
+ true)
+ (define-variable-local-value! buffer
+ (ref-variable-object comint-input-ring)
+ (make-ring (ref-variable comint-input-ring-size)))
+ (define-variable-local-value! buffer
+ (ref-variable-object comint-last-input-match)
+ false)
+ (define-variable-local-value! buffer
+ (ref-variable-object pseudo-shell-active?)
+ true)
+ (event-distributor/invoke! (ref-variable pseudo-shell-mode-hook)
+ buffer)))
+
+(define-variable pseudo-shell-mode-hook
+ "An event distributor that is invoked when entering Pseudo Shell mode."
+ (make-event-distributor))
+
+(define-variable pseudo-shell-active?
+ "Is this shell buffer active?"
+ false
+ boolean?)
+
+(define-key 'pseudo-shell #\C-a 'pseudo-shell-bol)
+(define-key 'pseudo-shell #\C-m 'pseudo-shell-execute-command)
+
+(define-key 'pseudo-shell #\M-p 'comint-previous-input)
+(define-key 'pseudo-shell #\M-n 'comint-next-input)
+(define-key 'pseudo-shell '(#\C-c #\C-r) 'comint-history-search-backward)
+(define-key 'pseudo-shell '(#\C-c #\C-s) 'comint-history-search-forward)
+(define-key 'pseudo-shell '(#\C-c #\C-w) 'backward-kill-word)
+
+;; (define-key 'pseudo-shell #\tab 'comint-dynamic-complete)
+;; (define-key 'pseudo-shell #\M-? 'comint-dynamic-list-completions)
+
+(define-command shell
+ "Run an inferior pseudo shell, with I/O through buffer *shell*.
+With prefix argument, unconditionally create a new buffer.
+If buffer exists, just switch to buffer *shell*.
+
+The buffer is put in Pseudo Shell mode, giving commands for sending input
+and tracking directories."
+ "P"
+ (lambda (new-buffer?)
+ (let ((buffer
+ (cond ((and (not new-buffer?)
+ (find-buffer "*shell*"))
+ => (lambda (buffer)
+ (let ((end (buffer-end buffer)))
+ (if (or (mark= end (line-start end 0))
+ (not (mark= end
+ (pseudo-shell-line-start end))))
+ (begin
+ (buffer-freshline buffer)
+ (insert-pseudo-shell-prompt!
+ (buffer-end buffer)))))
+ buffer))
+ (else
+ (let ((buffer (create-buffer "*shell*")))
+ (insert-pseudo-shell-prompt! (buffer-start buffer))
+ (set-buffer-major-mode! buffer
+ (ref-mode-object pseudo-shell))
+ (set-buffer-default-directory!
+ buffer
+ (buffer-default-directory (current-buffer)))
+ buffer)))))
+
+ (set-buffer-point! buffer (buffer-end buffer))
+ (define-variable-local-value! buffer
+ (ref-variable-object pseudo-shell-active?)
+ true)
+ (select-buffer buffer))))
+\f
+(define (insert-pseudo-shell-prompt! #!optional point)
+ ;; This corresponds to the $p$g prompt pattern.
+ (insert-string (string-append
+ (pseudo-directory-namestring
+ (buffer-default-directory (current-buffer)))
+ ">")
+ (if (default-object? point)
+ (current-point)
+ point)))
+
+(define (pseudo-directory-namestring dir)
+ (string-upcase
+ (->namestring
+ (directory-pathname-as-file dir))))
+
+(define-command pseudo-shell-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."
+ "P"
+ (lambda (argument)
+ (set-current-point!
+ (if argument
+ (line-start (current-point) 0)
+ (pseudo-shell-line-start (current-point))))))
+
+(define (pseudo-shell-line-start mark)
+ (let ((start (line-start mark 0)))
+ (let ((mark (search-forward ">" start (line-end start 0))))
+ (if (and mark (mark<= mark (line-end start 0)))
+ mark
+ start))))
+
+(define-command pseudo-shell-execute-command
+ "Execute the command on the current line."
+ ()
+ (lambda ()
+ (let ((point (current-point))
+ (buffer (current-buffer)))
+ (let ((start (pseudo-shell-line-start point))
+ (end (line-end point 0)))
+ (let ((command (extract-string start end)))
+ (ring-push! (ref-variable comint-input-ring)
+ command)
+ (if (not (mark= end (buffer-end buffer)))
+ (begin
+ (buffer-freshline buffer)
+ (insert-region (line-start start 0) end
+ (buffer-end buffer))))
+ (buffer-freshline buffer)
+ (unwind-protect
+ #f
+ (lambda ()
+ (pseudo-execute command
+ (buffer-default-directory buffer)
+ (buffer-end buffer))
+ (insert-newline (buffer-end buffer)))
+ (lambda ()
+ (if (ref-variable pseudo-shell-active? buffer)
+ (begin
+ (buffer-freshline buffer)
+ (insert-pseudo-shell-prompt! (buffer-end buffer))
+ (set-buffer-point! buffer (buffer-end buffer)))))))))))
+
+(define (buffer-freshline buffer)
+ (let* ((end (buffer-end buffer))
+ (start (line-start end 0)))
+ (if (not (mark= start end))
+ (insert-newline end))))
+\f
+(define (pseudo-execute command dir output-mark)
+ (let* ((command (string-trim command))
+ (next (string-find-next-char-in-set command char-set:whitespace))
+ (prog (if (not next)
+ command
+ (substring command 0 next))))
+ (let ((handler (assoc (string-downcase prog) pseudo-shell-builtins)))
+ (if (not handler)
+ (shell-command false output-mark dir command)
+ ((cdr handler) prog
+ (if (not next)
+ ""
+ (string-trim-left
+ (substring command (1+ next)
+ (string-length command))))
+ dir
+ output-mark)))))
+
+(define-variable pseudo-shell-dirstack
+ "List of directories saved by pushd in this buffer's shell."
+ '())
+
+(define-variable pseudo-shell-dirtrack? "" false)
+
+(define (pseudo-parse-directory dir prog args)
+ (cond ((string-null? args)
+ false)
+ ((string-find-next-char-in-set args char-set:whitespace)
+ (pseudo-error "Too many arguments" prog args))
+ (else
+ (let ((dir (merge-pathnames args dir)))
+ (if (not (file-directory? dir))
+ (pseudo-error "Not a directory" prog args))
+ (pathname-simplify (pathname-as-directory dir))))))
+
+(define (pseudo-error string . strings)
+ (apply editor-error string
+ (map (lambda (string)
+ (string-append " " string))
+ strings)))
+
+(define pseudo-shell-builtins
+ (let ((cd (lambda (prog args dir output-mark)
+ (if (not (ref-variable pseudo-shell-dirtrack?))
+ (editor-error "Not tracking directories"))
+ (let ((dir
+ (or (pseudo-parse-directory dir prog args)
+ (let ((home (get-environment-variable "HOME")))
+ (if (not home)
+ (pseudo-error "Unknown home:" prog)
+ (pathname-simplify
+ (pathname-as-directory
+ (merge-pathnames home dir))))))))
+ (set-default-directory dir)
+ (insert-string
+ (string-append (pseudo-directory-namestring dir)
+ "\n")
+ output-mark))))
+\f
+ (show-dirs
+ (lambda (dir output-mark)
+ (with-output-to-mark output-mark
+ (lambda ()
+ (write-char #\()
+ (write-string (pseudo-directory-namestring dir))
+ (let loop ((dirs (ref-variable pseudo-shell-dirstack)))
+ (if (null? dirs)
+ (begin
+ (write-char #\))
+ (write-char #\Newline))
+ (begin
+ (write-char #\Space)
+ (write-string (pseudo-directory-namestring (car dirs)))
+ (loop (cdr dirs))))))))))
+
+ `((""
+ . ,(lambda (prog args dir output-mark)
+ prog args dir output-mark ; ignored
+ (message "Empty command line")
+ (editor-beep)))
+
+ ("cd" . ,cd)
+
+ ("pushd"
+ . ,(lambda (prog args dir output-mark)
+ (if (not (ref-variable pseudo-shell-dirtrack?))
+ (editor-error "Not tracking directories"))
+ (let ((dir* (pseudo-parse-directory dir prog args))
+ (stack (ref-variable pseudo-shell-dirstack)))
+ (cond (dir*
+ (set-variable! pseudo-shell-dirstack (cons dir stack))
+ (set-default-directory dir*)
+ (show-dirs dir* output-mark))
+ ((null? stack)
+ (pseudo-error "Empty directory stack:" prog))
+ (else
+ (let ((dir* (car stack)))
+ (set-variable! pseudo-shell-dirstack
+ (cons dir (cdr stack)))
+ (set-default-directory dir*)
+ (show-dirs dir* output-mark)))))))
+
+ ("popd"
+ . ,(lambda (prog args dir output-mark)
+ dir ; ignored
+ (if (not (ref-variable pseudo-shell-dirtrack?))
+ (editor-error "Not tracking directories"))
+ (if (not (string-null? args))
+ (pseudo-error "Too many arguments:" prog)
+ (let ((stack (ref-variable pseudo-shell-dirstack)))
+ (if (null? stack)
+ (pseudo-error "Directory stack is empty:" prog)
+ (let ((dir (car stack)))
+ (set-variable! pseudo-shell-dirstack (cdr stack))
+ (set-default-directory dir)
+ (insert-string
+ (string-append (pseudo-directory-namestring dir)
+ "\n")
+ output-mark)))))))
+
+ ("dirs"
+ . ,(lambda (prog args dir output-mark)
+ (if (not (ref-variable pseudo-shell-dirtrack?))
+ (editor-error "Not tracking directories"))
+ (if (not (string-null? args))
+ (pseudo-error "Too many arguments:" prog))
+ (show-dirs dir output-mark)))
+
+ ("cwd" . ,cd)
+
+ ("exit"
+ . ,(lambda (prog args dir output-mark)
+ prog args dir ; ignored
+ (define-variable-local-value! (mark-buffer output-mark)
+ (ref-variable-object pseudo-shell-active?)
+ false)
+ (message "Pseudo exitted"))))))
+\f
+;;; Edwin variables:
+;;; scheme-environment: (->environment '(edwin))
+;;; scheme-syntax-table: (access edwin-syntax-table (->environment '(edwin)))
+;;; End:
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: dosproc.scm,v 1.1 1993/02/25 02:46:19 gjr Exp $
+
+Copyright (c) 1992-1993 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. |#
+
+;;;; Subprocess Support for DOS
+;;; package: (runtime)
+
+(declare (usual-integrations))
+\f
+(define run-subprocess
+ (let ((prim (make-primitive-procedure 'run-subprocess 4))
+ (channel-descriptor
+ (access channel-descriptor (->environment '(runtime primitive-io)))))
+
+ (lambda (string #!optional stdin stdout stderr)
+ (define (run in out err)
+ (let ((value (prim string in out err)))
+ (cond ((zero? value)
+ unspecific)
+ ((< value 0)
+ (error "run-subprocess: Not available"))
+ (else
+ (error "run-subprocess: Command failed" value)))))
+
+ (define (with-channel-output-port port recvr)
+ (call-with-temporary-filename
+ (lambda (fname)
+ (let ((value
+ (call-with-output-file fname
+ (lambda (port*)
+ (recvr
+ (channel-descriptor
+ (output-port/channel port*)))))))
+ (call-with-input-file fname
+ (lambda (input)
+ (let ((string (read-string (char-set) input)))
+ (if (not (eof-object? string))
+ (write-string string
+ port)))))
+ value))))
+
+ (define (with-channel-input-port port recvr)
+ (call-with-temporary-filename
+ (lambda (fname)
+ (call-with-output-file fname
+ (lambda (output)
+ (write-string (read-string (char-set) port)
+ output)))
+ (call-with-input-file fname
+ (lambda (port*)
+ (recvr
+ (channel-descriptor
+ (input-port/channel port*))))))))
+
+ (define (with-output-channel in out)
+ (cond ((default-object? stderr)
+ (run in out out))
+ ((eq? stderr #t)
+ (run in out -1))
+ ((not (output-port? stderr))
+ (error "run: stderr not an output port" stderr))
+ ((output-port/channel stderr)
+ =>
+ (lambda (channel)
+ (output-port/flush-output stderr)
+ (run in out (channel-descriptor channel))))
+ (else
+ (with-channel-output-port stdout
+ (lambda (err)
+ (run in out err))))))
+
+ (define (with-input-channel in)
+ (let ((stdout
+ (if (or (default-object? stdout)
+ (not stdout))
+ (let ((port (current-output-port)))
+ (fresh-line port)
+ port)
+ stdout)))
+ (cond ((eq? stdout #t)
+ (with-output-channel in -1))
+ ((not (output-port? stdout))
+ (error "run: stdout not an output port" stdout))
+ ((output-port/channel stdout)
+ =>
+ (lambda (channel)
+ (output-port/flush-output stdout)
+ (with-output-channel in (channel-descriptor channel))))
+ (else
+ (with-channel-output-port stdout
+ (lambda (out)
+ (with-output-channel in out)))))))
+
+ (cond ((or (default-object? stdin)
+ (eq? stdin #t))
+ (with-input-channel -1))
+ ((not (input-port? stdin))
+ (error "run: stdin not an input port" stdin))
+ ((input-port/channel stdin)
+ => (lambda (channel)
+ (with-input-channel (channel-descriptor channel))))
+ (else
+ (with-channel-input-port stdin
+ with-input-channel))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff