From 3ba912c717216c3fb74f5c923fd7aa90e86aee35 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 23 Jan 1995 20:06:07 +0000 Subject: [PATCH] Eliminate several operating-system dependencies. --- v7/src/edwin/dos.scm | 49 ++++----------------------------------- v7/src/edwin/filcom.scm | 27 ++++++++++----------- v7/src/edwin/os2.scm | 35 +++++++--------------------- v7/src/edwin/process.scm | 5 ++-- v7/src/edwin/sendmail.scm | 6 ++--- v7/src/edwin/unix.scm | 37 ++--------------------------- 6 files changed, 34 insertions(+), 125 deletions(-) diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm index 22df8a1c1..487fad17b 100644 --- a/v7/src/edwin/dos.scm +++ b/v7/src/edwin/dos.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dos.scm,v 1.19 1994/12/19 19:41:51 cph Exp $ +;;; $Id: dos.scm,v 1.20 1995/01/23 20:05:12 cph Exp $ ;;; -;;; Copyright (c) 1992-1994 Massachusetts Institute of Technology +;;; Copyright (c) 1992-95 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -134,23 +134,8 @@ Includes the new backup. Must be > 0." (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 os/pathname->display-string + ->namestring) (define (file-type->version type version) (let ((version-string @@ -278,30 +263,6 @@ Includes the new backup. Must be > 0." (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)))) (define dos/encoding-pathname-types '()) @@ -340,7 +301,7 @@ Includes the new backup. Must be > 0." (define (os/completion-ignore-filename? filename) (or (os/backup-filename? filename) (os/auto-save-filename? filename) - (and (not (os/file-directory? filename)) + (and (not (file-directory? filename)) (there-exists? (ref-variable completion-ignored-extensions) (lambda (extension) (string-suffix? extension filename)))))) diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm index 3cf4345e6..0781e1498 100644 --- a/v7/src/edwin/filcom.scm +++ b/v7/src/edwin/filcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: filcom.scm,v 1.182 1995/01/16 20:46:15 cph Exp $ +;;; $Id: filcom.scm,v 1.183 1995/01/23 20:05:29 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-95 Massachusetts Institute of Technology ;;; @@ -645,9 +645,9 @@ If a file with the new name already exists, confirmation is requested first." (filename-complete-string (prompt-string->pathname string directory) (lambda (filename) - (if-unique (os/filename->display-string filename))) + (if-unique (os/pathname->display-string filename))) (lambda (prefix get-completions) - (if-not-unique (os/filename->display-string prefix) + (if-not-unique (os/pathname->display-string prefix) get-completions)) if-not-found)) (lambda (string) @@ -664,22 +664,22 @@ If a file with the new name already exists, confirmation is requested first." (define (loop directory filenames) (let ((unique-case (lambda (filename) - (let ((filename (os/make-filename directory filename))) - (if (os/file-directory? filename) + (let ((pathname (merge-pathnames filename directory))) + (if (file-directory? pathname) ;; Note: We assume here that all directories contain ;; at least one file. Thus directory names should ;; complete, but not uniquely. - (let ((dir (os/filename-as-directory filename))) + (let ((dir (->namestring (pathname-as-directory pathname)))) (if-not-unique dir (lambda () (canonicalize-filename-completions dir (os/directory-list dir))))) - (if-unique filename))))) + (if-unique (->namestring pathname)))))) (non-unique-case (lambda (filenames*) (let ((string (string-greatest-common-prefix filenames*))) - (if-not-unique (os/make-filename directory string) + (if-not-unique (->namestring (merge-pathnames string directory)) (lambda () (canonicalize-filename-completions directory @@ -692,7 +692,7 @@ If a file with the new name already exists, confirmation is requested first." (list-transform-negative filenames (lambda (filename) (completion-ignore-filename? - (os/make-filename directory filename)))))) + (merge-pathnames filename directory)))))) (cond ((null? filtered-filenames) (non-unique-case filenames)) ((null? (cdr filtered-filenames)) @@ -701,7 +701,7 @@ If a file with the new name already exists, confirmation is requested first." (non-unique-case filtered-filenames))))))) (let ((directory (directory-namestring pathname)) (prefix (file-namestring pathname))) - (cond ((not (os/file-directory? directory)) + (cond ((not (file-directory? directory)) (if-not-found)) ((string-null? prefix) ;; This optimization assumes that all directories @@ -734,9 +734,10 @@ If a file with the new name already exists, confirmation is requested first." (define (canonicalize-filename-completions directory filenames) (do ((filenames filenames (cdr filenames))) ((null? filenames)) - (if (os/file-directory? (os/make-filename directory (car filenames))) - (set-car! filenames (os/filename-as-directory (car filenames))))) + (if (file-directory? (merge-pathnames (car filenames) directory)) + (set-car! filenames + (->namestring (pathname-as-directory (car filenames)))))) (sort filenames stringnamestring filename))) \ No newline at end of file diff --git a/v7/src/edwin/os2.scm b/v7/src/edwin/os2.scm index 68d8fb965..74e0ff10d 100644 --- a/v7/src/edwin/os2.scm +++ b/v7/src/edwin/os2.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: os2.scm,v 1.4 1995/01/19 19:41:55 cph Exp $ +;;; $Id: os2.scm,v 1.5 1995/01/23 20:05:42 cph Exp $ ;;; ;;; Copyright (c) 1994-95 Massachusetts Institute of Technology ;;; @@ -91,15 +91,11 @@ Includes the new backup. Must be > 0." (else (string-tail string start)))))) (define (os/pathname->display-string pathname) - (let ((homedir (user-homedir-pathname))) - (if (let ((d1 (pathname-device pathname)) - (d2 (pathname-device homedir))) - (and d1 d2 (string-ci=? d1 d2))) - (let ((pathname (enough-pathname pathname homedir))) - (if (pathname-absolute? pathname) - (->namestring pathname) - (string-append "~\\" (->namestring pathname)))) - (->namestring pathname)))) + (or (let ((relative (enough-pathname pathname (user-homedir-pathname)))) + (and (not (pathname-device relative)) + (not (pathname-absolute? relative)) + (string-append "~\\" (->namestring relative)))) + (->namestring pathname))) (define (os/truncate-filename-for-modeline filename width) (let ((length (string-length filename))) @@ -269,7 +265,7 @@ Includes the new backup. Must be > 0." (define (os/completion-ignore-filename? filename) (or (os/backup-filename? filename) (os/auto-save-filename? filename) - (and (not (os/file-directory? filename)) + (and (not (file-directory? filename)) (there-exists? (ref-variable completion-ignored-extensions) (lambda (extension) (string-suffix? extension filename)))))) @@ -488,19 +484,4 @@ Includes the new backup. Must be > 0." (loop (cons name result)) (begin (directory-channel-close channel) - result)))))) - -(define os/file-directory? - file-directory?) - -(define-integrable (os/make-filename directory filename) - (->namestring (merge-pathnames filename directory))) - -(define-integrable (os/filename-as-directory filename) - (->namestring (pathname-as-directory filename))) - -(define os/filename-non-directory - file-namestring) - -(define os/filename->display-string - os/pathname->display-string) \ No newline at end of file + result)))))) \ No newline at end of file diff --git a/v7/src/edwin/process.scm b/v7/src/edwin/process.scm index cdfe8cdb8..c56e61e6c 100644 --- a/v7/src/edwin/process.scm +++ b/v7/src/edwin/process.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: process.scm,v 1.34 1995/01/06 01:14:37 cph Exp $ +;;; $Id: process.scm,v 1.35 1995/01/23 20:05:52 cph Exp $ ;;; ;;; Copyright (c) 1991-95 Massachusetts Institute of Technology ;;; @@ -544,8 +544,7 @@ after the listing is made.)" (set! process (start-subprocess program - (list->vector - (cons (os/filename-non-directory program) arguments)) + (list->vector (cons (file-namestring program) arguments)) (if directory (cons false (->namestring directory)) false) diff --git a/v7/src/edwin/sendmail.scm b/v7/src/edwin/sendmail.scm index 2badae72e..a6e94824e 100644 --- a/v7/src/edwin/sendmail.scm +++ b/v7/src/edwin/sendmail.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: sendmail.scm,v 1.19 1994/03/08 20:20:21 cph Exp $ +;;; $Id: sendmail.scm,v 1.20 1995/01/23 20:06:00 cph Exp $ ;;; -;;; Copyright (c) 1991-94 Massachusetts Institute of Technology +;;; Copyright (c) 1991-95 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -522,7 +522,7 @@ Numeric argument means justify as well." (let ((process (start-pipe-subprocess program - (vector (os/filename-non-directory program) + (vector (file-namestring program) "-oi" "-t" (string-append "-f" user-name) ;; These mean "report errors by mail" and diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm index 5f3685663..4c7c07ac8 100644 --- a/v7/src/edwin/unix.scm +++ b/v7/src/edwin/unix.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: unix.scm,v 1.44 1995/01/06 01:08:47 cph Exp $ +;;; $Id: unix.scm,v 1.45 1995/01/23 20:06:07 cph Exp $ ;;; ;;; Copyright (c) 1989-95 Massachusetts Institute of Technology ;;; @@ -110,17 +110,6 @@ Includes the new backup. Must be > 0." (->namestring pathname) (string-append "~/" (->namestring pathname))))) -(define (os/filename->display-string filename) - (let ((home (unix/current-home-directory))) - (cond ((not (string-prefix? home filename)) - filename) - ((string=? home filename) - "~") - ((char=? #\/ (string-ref filename (string-length home))) - (string-append "~" (string-tail filename (string-length home)))) - (else - filename)))) - (define (os/auto-save-pathname pathname buffer) (let ((wrap (lambda (name directory) @@ -285,28 +274,6 @@ Includes the new backup. Must be > 0." (begin (directory-channel-close channel) result)))))) - -(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 filename 0 end #\/))) - (and index - (substring filename 0 (+ index 1)))))) - -(define (os/filename-non-directory filename) - (let ((end (string-length filename))) - (let ((index (substring-find-previous-char filename 0 end #\/))) - (if index - (substring filename (+ index 1) end) - filename)))) (define unix/encoding-pathname-types '("Z" "gz" "KY")) @@ -354,7 +321,7 @@ Includes the new backup. Must be > 0." type))) (define (os/completion-ignore-filename? filename) - (and (not (os/file-directory? filename)) + (and (not (file-directory? filename)) (there-exists? (ref-variable completion-ignored-extensions) (lambda (extension) (string-suffix? extension filename))))) -- 2.25.1