From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 23 Jan 1995 20:06:07 +0000 (+0000)
Subject: Eliminate several operating-system dependencies.
X-Git-Tag: 20090517-FFI~6705
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3ba912c717216c3fb74f5c923fd7aa90e86aee35;p=mit-scheme.git
Eliminate several operating-system dependencies.
---
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 string<?))
(define-integrable (completion-ignore-filename? filename)
- (os/completion-ignore-filename? filename))
\ No newline at end of file
+ (os/completion-ignore-filename? (->namestring 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)))))