--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/dos.scm,v 1.1 1992/05/12 15:29:45 mhwu Exp $
+;;;
+;;; Copyright (c) 1992 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.
+;;;
+
+;;;; DOS Customizations for Edwin
+
+(declare (usual-integrations))
+\f
+(define-variable backup-by-copying-when-linked
+ "True means use copying to create backups for files with multiple names.
+This causes the alternate names to refer to the latest version as edited.
+This variable is relevant only if backup-by-copying is false."
+ false
+ boolean?)
+
+(define-variable backup-by-copying-when-mismatch
+ "True means create backups by copying if this preserves owner or group.
+Renaming may still be used (subject to control of other variables)
+when it would not result in changing the owner or group of the file;
+that is, for files which are owned by you and whose group matches
+the default for a new file created there by you.
+This variable is relevant only if Backup By Copying is false."
+ false
+ boolean?)
+
+(define-variable version-control
+ "Control use of version numbers for backup files.
+#T means make numeric backup versions unconditionally.
+#F means make them for files that have some already.
+'NEVER means do not make them."
+ true
+ (lambda (thing)
+ (or (eq? thing 'NEVER) (boolean? thing))))
+
+(define-variable kept-old-versions
+ "Number of oldest versions to keep when a new numbered backup is made."
+ 2
+ exact-nonnegative-integer?)
+
+(define-variable kept-new-versions
+ "Number of newest versions to keep when a new numbered backup is made.
+Includes the new backup. Must be > 0."
+ 2
+ (lambda (n) (and (exact-integer? n) (> n 0))))
+\f
+
+(define os/directory-char-set (char-set #\\ #\/))
+
+(define (os/trim-pathname-string string)
+ ;; Trim a filename with false starts to a unique name
+ (define (trim-for-duplicate-top-level-directory string)
+ (let ((end (string-length string)))
+ (let loop ((index end))
+ (let ((slash
+ (substring-find-previous-char-in-set string 0 index
+ os/directory-char-set)))
+ (cond ((not slash) string)
+ ((and (fix:< (1+ slash) end)
+ (char=? (string-ref string (1+ slash)) #\$))
+ (string-tail string (fix:1+ slash)))
+ ((zero? slash)
+ string)
+ ((char-set-member? os/directory-char-set
+ (string-ref string (fix:-1+ slash)))
+ (string-tail string slash))
+ (else
+ (loop (fix:-1+ slash))))))))
+ (define (trim-for-duplicate-device string)
+ (let ((end (string-length string))
+ (sep (char-set-union (char-set #\: #\$) os/directory-char-set)))
+ (let ((colon
+ (substring-find-previous-char string 0 end #\:)))
+ (cond ((or (not colon) (zero? colon))
+ string)
+ ((and (fix:< (fix:1+ colon) end)
+ (char=? (string-ref string (fix:1+ colon)) #\$))
+ (string-tail string (fix:1+ colon)))
+ ((substring-find-previous-char-in-set string 0 colon sep)
+ =>
+ (lambda (before)
+ (string-tail string
+ (if (char=? (string-ref string before) #\$)
+ before
+ (fix:1+ before)))))
+ (else
+ string)))))
+ (trim-for-duplicate-device (trim-for-duplicate-top-level-directory string)))
+
+
+(define (os/pathname->display-string pathname)
+ (os/filename->display-string (->namestring pathname)))
+
+(define (os/filename->display-string filename)
+ (let ((name (string-copy filename)))
+ (slash->backslash! name)
+ name))
+
+(define (slash->backslash! name)
+ (let ((end (string-length name)))
+ (let loop ((index 0))
+ (let ((slash (substring-find-next-char name index end #\/)))
+ (if (not slash)
+ '()
+ (begin
+ (string-set! name slash #\\)
+ (loop (1+ slash))))))))
+
+(define (file-type->version type version)
+ (let ((version-string
+ (and (fix:fixnum? version)
+ (number->string (fix:remainder version 1000)))))
+ (if (not version-string)
+ (error "Illegal version" version)
+ (let ((version-string
+ (string-pad-left version-string 3 #\0)))
+ (if (string? type)
+ (if (fix:> (string-length type) 0)
+ (string-append (substring type 0 1)
+ (substring version-string 1 3))
+ version-string)
+ version-string)))))
+
+(define (filename->version-number filename)
+ (let ((type (pathname-type filename)))
+ (and (string? type)
+ (fix:= (string-length type) 3)
+ (or (string->number type)
+ (string->number (substring type 1 3))))))
+
+(define (os/auto-save-pathname pathname buffer)
+ buffer
+ (pathname-new-type pathname
+ (file-type->version (pathname-type pathname) 0)))
+
+(define (os/precious-backup-pathname pathname)
+ ;; Use the autosave name for the precious backup
+ (pathname-new-type pathname
+ (file-type->version (pathname-type pathname) 0)))
+
+(define (os/backup-buffer? truename)
+ (and (memv (string-ref
+ (file-attributes/mode-string (file-attributes truename)) 0)
+ '(#\- #\l))
+ (not
+ (let ((directory (pathname-directory truename)))
+ (and (pair? directory)
+ (eq? 'ABSOLUTE (car directory))
+ (pair? (cdr directory))
+ (eqv? "tmp" (cadr directory)))))))
+
+(define (os/default-backup-filename)
+ "c:/tmp/edwin.bak")
+
+(define (os/truncate-filename-for-modeline filename width)
+ (let ((length (string-length filename)))
+ (if (< 0 width length)
+ (let ((result
+ (substring
+ filename
+ (let ((index (- length width)))
+ (or (and (not
+ (char-set-member? os/directory-char-set
+ (string-ref filename index)))
+ (substring-find-next-char-in-set
+ filename index length os/directory-char-set))
+ (1+ index)))
+ length)))
+ (string-set! result 0 #\$)
+ result)
+ filename)))
+\f
+(define (os/backup-by-copying? truename)
+ truename
+ false)
+
+(define (os/buffer-backup-pathname truename)
+ (let ((directory (directory-namestring truename))
+ (type (pathname-type truename))
+ (filename (pathname-name truename)))
+
+ (define (no-versions)
+ (values (pathname-new-type truename (file-type->version type 0)) '()))
+ (define (version->pathname version)
+ (pathname-new-type truename (file-type->version type version)))
+ (define (files->versions files)
+ (if (or (not files) (null? files))
+ '()
+ (let ((type-number (filename->version-number (car files))))
+ (if type-number
+ (cons type-number (files->versions (cdr files)))
+ (files->versions (cdr files))))))
+
+ (if (eq? 'NEVER (ref-variable version-control))
+ (no-versions)
+ (let ((search-name (string-append filename ".")))
+ (let ((filenames
+ (os/directory-list-completions directory search-name)))
+ (let ((versions (sort (files->versions filenames) <)))
+ (let ((high-water-mark (apply max (cons 0 versions))))
+ (if (or (ref-variable version-control)
+ (positive? high-water-mark))
+ (values
+ (version->pathname (+ high-water-mark 1))
+ (let ((start (ref-variable kept-old-versions))
+ (end (fix:- (length versions)
+ (fix:-1+
+ (ref-variable kept-new-versions)))))
+ (if (fix:< start end)
+ (map version->pathname
+ (sublist versions start end))
+ '())))
+ (no-versions)))))))))
+\f
+
+(define (os/directory-list-completions directory prefix)
+ (define (->directory-namestring s)
+ (->namestring (pathname-as-directory (->pathname s))))
+ (define (->directory-wildcard s)
+ (string-append (->directory-namestring s) "*.*"))
+ (let ((plen (string-length prefix)))
+ (let loop ((pathnames (directory-read (->directory-wildcard directory))))
+ (if (null? pathnames)
+ '()
+ (let ((filename (file-namestring (car pathnames))))
+ (if (and (fix:>= (string-length filename) plen)
+ (string-ci=? prefix (substring filename 0 plen)))
+ (cons filename (loop (cdr pathnames)))
+ (loop (cdr pathnames))))))))
+
+(define (os/directory-list directory)
+ (os/directory-list-completions directory ""))
+
+(define-integrable os/file-directory?
+ (ucode-primitive file-directory?))
+
+(define-integrable (os/make-filename directory filename)
+ (string-append directory filename))
+
+(define-integrable (os/filename-as-directory filename)
+ (string-append filename "\\"))
+
+(define (os/filename-directory filename)
+ (let ((end (string-length filename)))
+ (let ((index (substring-find-previous-char-in-set
+ filename 0 end os/directory-char-set)))
+ (and index
+ (substring filename 0 (+ index 1))))))
+
+(define (os/filename-non-directory filename)
+ (let ((end (string-length filename)))
+ (let ((index (substring-find-previous-char-in-set
+ filename 0 end os/directory-char-set)))
+ (if index
+ (substring filename (+ index 1) end)
+ filename))))
+\f
+(define dos/encoding-pathname-types '())
+
+(define dos/backup-suffixes '())
+
+(define (os/backup-filename? filename)
+ (let ((version (filename->version-number filename)))
+ (and (fix:fixnum? version)
+ (fix:> version 0))))
+
+(define (os/auto-save-filename? filename)
+ (let ((version (filename->version-number filename)))
+ (and (fix:fixnum? version)
+ (fix:= version 0))))
+
+(define (os/pathname-type-for-mode pathname)
+ (let ((type (pathname-type pathname)))
+ (if (member type dos/encoding-pathname-types)
+ (pathname-type (->namestring (pathname-new-type pathname false)))
+ type)))
+
+(define (os/completion-ignore-filename? filename)
+ (or (os/backup-filename? filename)
+ (os/auto-save-filename? filename)
+ (and (not (os/file-directory? filename))
+ (there-exists? (ref-variable completion-ignored-extensions)
+ (lambda (extension)
+ (string-suffix? extension filename))))))
+
+(define (os/completion-ignored-extensions)
+ (append '(".bin" ".com" ".ext" ".inf"
+ ".psb" ".moc" ".fni"
+ ".bco" ".bld" ".bad" ".glo" ".fre"
+ ".obj" ".exe" ".pif"
+ ".dvi" ".toc" ".log" ".aux")
+ (list-copy dos/backup-suffixes)))
+
+(define-variable completion-ignored-extensions
+ "Completion ignores filenames ending in any string in this list."
+ (os/completion-ignored-extensions)
+ (lambda (extensions)
+ (and (list? extensions)
+ (for-all? extensions
+ (lambda (extension)
+ (and (string? extension)
+ (not (string-null? extension))))))))
+
+(define (os/file-type-to-major-mode)
+ (alist-copy
+ `(("article" . text)
+ ("asm" . midas)
+ ("bat" . text)
+ ("bib" . text)
+ ("c" . c)
+ ("cc" . c)
+ ("h" . c)
+ ("m4" . midas)
+ ("pas" . pascal)
+ ("s" . scheme)
+ ("scm" . scheme)
+ ("text" . text)
+ ("txi" . texinfo)
+ ("txt" . text)
+ ("y" . c))))
+\f
+
+(define (os/init-file-name)
+ (let* ((home (dos/current-home-directory))
+ (user-init-file (merge-pathnames "edwin.ini" home)))
+ (if (file-exists? user-init-file)
+ (->namestring user-init-file)
+ "/scheme/lib/edwin.ini")))
+
+(define (os/find-file-initialization-filename pathname)
+ (or (and (equal? "scm" (pathname-type pathname))
+ (let ((pathname (pathname-new-type pathname "ffi")))
+ (and (file-exists? pathname)
+ pathname)))
+ (let ((pathname
+ (merge-pathnames "edwin.ffi" (directory-pathname pathname))))
+ (and (file-exists? pathname)
+ pathname))))
+
+(define (os/read-file-methods) '())
+
+(define (os/write-file-methods) '())
+
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/dosproc.scm,v 1.1 1992/05/12 15:30:35 mhwu Exp $
+;;;
+;;; Copyright (c) 1991-92 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, faked in DOS because too many things depend on this
+
+(declare (usual-integrations))
+\f
+(define (initialize-processes!)
+ (set! edwin-processes '())
+ )
+
+(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)."
+ '()
+ null?)
+
+(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)
+ process
+ false)
+
+(define (process-runnable? process)
+ process
+ false)
+
+(define-integrable (process-buffer process)
+ process
+ false)
+
+(define (set-process-buffer! process buffer)
+ process buffer
+ false)
+
+\f
+(define (start-process name buffer environment program . arguments)
+ name buffer environment program arguments
+ false)
+
+(define (delete-process process)
+ process
+ false)
+
+(define (get-process-by-name name)
+ name
+ false)
+
+(define (get-buffer-process buffer)
+ buffer
+ false)
+
+(define (buffer-processes buffer)
+ buffer
+ '())
+
+\f
+;;;; Input and Output
+
+(define (process-send-eof process)
+ process
+ false)
+
+(define (process-send-substring process string start end)
+ process string start end
+ false)
+
+(define (process-send-string process string)
+ process string
+ false)
+
+(define (process-send-char process char)
+ process char
+ false)
+
+(define (accept-process-output) "")
+
+(define (handle-process-status-changes) false)
+
+(define (process-status-message status reason)
+ status reason
+ "")
+
+\f
+;;;; Signals
+
+(define (interrupt-process process group?)
+ process group?
+ false)
+
+(define (quit-process process group?)
+ process group?
+ false)
+
+(define (hangup-process process group?)
+ process group?
+ false)
+
+(define (stop-process process group?)
+ process group?
+ false)
+
+(define (continue-process process group?)
+ process group?
+ false)
+
+(define (kill-process process group?)
+ process group?
+ false)
+\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 () '()))
+
+
+(define (process-arguments->string arguments)
+ arguments
+ "")
+
+(define (process-list)
+ (list-copy edwin-processes))
+\f
+;;;; Synchronous Subprocesses
+
+(define (run-synchronous-process input-region output-mark directory pty?
+ program . arguments)
+ input-region output-mark directory pty? program arguments
+ false)
+
+
+(define (synchronous-process-wait process input-region output-mark)
+ process input-region output-mark
+ false)
+
+
+(define (call-with-output-copier process output-mark receiver)
+ process output-mark
+ (receiver (lambda () false)))
+
+(define (call-with-input-copier process input-region receiver)
+ process input-region
+ (receiver (lambda () false)))
+
+(define system-call-name
+ (condition-accessor condition-type:system-call-error 'SYSTEM-CALL))
+
+(define system-call-error
+ (condition-accessor condition-type:system-call-error 'ERROR-TYPE))
+\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?)
+ command insert-at-point?
+ (message "(Shell command not available)")
+ false))
+
+(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?)
+ region command replace-region?
+ (message "(Shell command not available)")
+ false))
+
+(define (shell-command-pop-up-output generate-output)
+ generate-output
+ false)
+
+(define (shell-command input-region output-mark directory pty? command)
+ input-region output-mark directory pty? command
+ false)
+\f
+;;; These procedures are not specific to the process abstraction.
+
+(define (find-program program default-directory)
+ program default-directory
+ false)
+
+(define (parse-path-string string)
+ string
+ false)
+
+(define (process-environment-bind environment . bindings)
+ environment bindings
+ false)
+
+(define (environment-binding-name binding)
+ binding
+ false)
+
+(define (find-environment-variable name bindings)
+ name bindings
+ false)
projects / mit-scheme.git / commitdiff