From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Thu, 25 Feb 1993 02:50:59 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~8463
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b74fb47d410399cac8c8c4699a9ada6c3a43b434;p=mit-scheme.git

Initial revision
---

diff --git a/v7/src/edwin/doscom.scm b/v7/src/edwin/doscom.scm
new file mode 100644
index 000000000..8d3b8feea
--- /dev/null
+++ b/v7/src/edwin/doscom.scm
@@ -0,0 +1,119 @@
+#| -*-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))
+
+(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
diff --git a/v7/src/edwin/dosshell.scm b/v7/src/edwin/dosshell.scm
new file mode 100644
index 000000000..923616347
--- /dev/null
+++ b/v7/src/edwin/dosshell.scm
@@ -0,0 +1,344 @@
+#| -*-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))
+
+(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))))
+
+(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))))
+
+(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))))
+
+	(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"))))))
+
+;;; Edwin variables:
+;;; scheme-environment: (->environment '(edwin))
+;;; scheme-syntax-table: (access edwin-syntax-table (->environment '(edwin)))
+;;; End:
diff --git a/v7/src/runtime/dosproc.scm b/v7/src/runtime/dosproc.scm
new file mode 100644
index 000000000..b79673486
--- /dev/null
+++ b/v7/src/runtime/dosproc.scm
@@ -0,0 +1,134 @@
+#| -*-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))
+
+(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