From 73aca627ddf29ef30ab3141af41061972828b0b9 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 12 May 2001 20:03:21 +0000 Subject: [PATCH] Use new predicate DIRECTORY-PATHNAME? to replace various ad-hoc mechanisms previously used to detect the same thing. --- v7/src/edwin/filcom.scm | 26 +++++++++++--------------- v7/src/edwin/print.scm | 12 ++++++------ v7/src/imail/imail-util.scm | 6 +++--- v7/src/runtime/dosdir.scm | 25 ++++++++++++------------- v7/src/runtime/unxdir.scm | 25 ++++++++++++------------- 5 files changed, 44 insertions(+), 50 deletions(-) diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm index b7c5c5d30..1ad5b6cc3 100644 --- a/v7/src/edwin/filcom.scm +++ b/v7/src/edwin/filcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: filcom.scm,v 1.216 2001/05/10 19:06:17 cph Exp $ +;;; $Id: filcom.scm,v 1.217 2001/05/12 20:02:19 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology ;;; @@ -471,15 +471,10 @@ all buffers." boolean?) (define (pathname->buffer-name pathname) - (let ((pathname - (let ((pathname (->pathname pathname))) - (if (pathname-name pathname) - pathname - (directory-pathname-as-file pathname))))) - (let ((name (file-namestring pathname))) - (if (string-null? name) - (->namestring pathname) - name)))) + (let ((pathname (directory-pathname-as-file (->pathname pathname)))) + (if (directory-pathname? pathname) + (->namestring pathname) + (file-namestring pathname)))) (define (pathname->buffer pathname) (let ((pathname (->pathname pathname))) @@ -497,11 +492,11 @@ if you wish to make buffer not be visiting any file." (set-visited-pathname (selected-buffer) (let ((pathname (->pathname filename))) - (and (not (string-null? (file-namestring pathname))) + (and (not (directory-pathname? pathname)) pathname))))) (define (set-visited-pathname buffer pathname) - (if (and pathname (not (pathname-name pathname))) + (if (and pathname (directory-pathname? pathname)) (editor-error "File name cannot be a directory: " (->namestring pathname))) (set-buffer-pathname! buffer pathname) @@ -808,7 +803,6 @@ Prefix arg means treat the plaintext file as binary data." (define (filename-complete-string pathname if-unique if-not-unique if-not-found) (let ((directory (directory-namestring pathname)) - (prefix (file-namestring pathname)) (if-directory (lambda (directory) (if-not-unique directory @@ -818,10 +812,12 @@ Prefix arg means treat the plaintext file as binary data." (os/directory-list directory))))))) (cond ((not (file-test-no-errors file-directory? directory)) (if-not-found)) - ((string-null? prefix) + ((directory-pathname? pathname) (if-directory directory)) (else - (let ((filenames (os/directory-list-completions directory prefix)) + (let ((filenames + (os/directory-list-completions directory + (file-namestring pathname))) (unique-case (lambda (filename) (let ((pathname (merge-pathnames filename directory))) diff --git a/v7/src/edwin/print.scm b/v7/src/edwin/print.scm index c1f83c443..591bd93a7 100644 --- a/v7/src/edwin/print.scm +++ b/v7/src/edwin/print.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: print.scm,v 1.19 2000/04/30 22:17:07 cph Exp $ +;;; $Id: print.scm,v 1.20 2001/05/12 20:02:33 cph Exp $ ;;; -;;; Copyright (c) 1991-2000 Massachusetts Institute of Technology +;;; Copyright (c) 1991-2001 Massachusetts Institute of Technology ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -16,7 +16,8 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;;; 02111-1307, USA. ;;;; Print Buffers and Regions @@ -107,9 +108,8 @@ Variable LPR-SWITCHES is a list of extra switches (strings) to pass to lpr." (and buffer (or (let ((pathname (buffer-pathname buffer))) (and pathname - (let ((filename (file-namestring pathname))) - (and (not (string-null? filename)) - filename)))) + (not (directory-pathname? pathname)) + (file-namestring pathname))) (string-append "Edwin buffer " (buffer-name buffer))))))) (if (or (not buffer-title) (and (group-start? (region-start region)) diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm index 857646c23..98c477930 100644 --- a/v7/src/imail/imail-util.scm +++ b/v7/src/imail/imail-util.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-util.scm,v 1.35 2001/03/19 22:17:37 cph Exp $ +;;; $Id: imail-util.scm,v 1.36 2001/05/12 20:03:21 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -329,7 +329,7 @@ (lambda () (filtered-list pathname filter)))))) (cond ((not (safe-file-directory? (directory-pathname pathname))) (if-not-found)) - ((string-null? (file-namestring pathname)) + ((directory-pathname? pathname) (if-directory pathname)) (else (let ((pathnames (filtered-completions pathname filter))) @@ -340,7 +340,7 @@ (string-greatest-common-prefix (map ->namestring pathnames))) (lambda () pathnames))) - ((string-null? (file-namestring (car pathnames))) + ((directory-pathname? (car pathnames)) (if-directory (car pathnames))) (else (if-unique (car pathnames))))))))) diff --git a/v7/src/runtime/dosdir.scm b/v7/src/runtime/dosdir.scm index 01043935c..cd9a29ac8 100644 --- a/v7/src/runtime/dosdir.scm +++ b/v7/src/runtime/dosdir.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: dosdir.scm,v 1.9 1999/06/21 21:05:27 cph Exp $ +$Id: dosdir.scm,v 1.10 2001/05/12 20:03:01 cph Exp $ -Copyright (c) 1992, 1999 Massachusetts Institute of Technology +Copyright (c) 1992, 1999-2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -16,7 +16,8 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. |# ;;;; DOS Directory Reader @@ -35,16 +36,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define (directory-read-nosort pattern) (let ((pattern (let ((pattern (adjust-directory-pattern (merge-pathnames pattern)))) - (let ((name (pathname-name pattern)) - (type (pathname-type pattern))) - (if (or name type) - pattern - (make-pathname (pathname-host pattern) - (pathname-device pattern) - (pathname-directory pattern) - 'WILD - 'WILD - (pathname-version pattern))))))) + (if (directory-pathname? pattern) + (make-pathname (pathname-host pattern) + (pathname-device pattern) + (pathname-directory pattern) + 'WILD + 'WILD + (pathname-version pattern)) + pattern)))) (let ((directory-path (directory-pathname pattern))) (map (lambda (pathname) (merge-pathnames pathname directory-path)) diff --git a/v7/src/runtime/unxdir.scm b/v7/src/runtime/unxdir.scm index 33be8daf3..df4c846c0 100644 --- a/v7/src/runtime/unxdir.scm +++ b/v7/src/runtime/unxdir.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: unxdir.scm,v 14.11 1999/01/02 06:19:10 cph Exp $ +$Id: unxdir.scm,v 14.12 2001/05/12 20:03:03 cph Exp $ -Copyright (c) 1988-1999 Massachusetts Institute of Technology +Copyright (c) 1988-2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -16,7 +16,8 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. |# ;;;; Directory Operations -- unix @@ -34,16 +35,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define (directory-read-nosort pattern) (let ((pattern (let ((pattern (merge-pathnames pattern))) - (let ((name (pathname-name pattern)) - (type (pathname-type pattern))) - (if (or name type) - pattern - (make-pathname (pathname-host pattern) - (pathname-device pattern) - (pathname-directory pattern) - 'WILD - 'WILD - (pathname-version pattern))))))) + (if (directory-pathname? pattern) + (make-pathname (pathname-host pattern) + (pathname-device pattern) + (pathname-directory pattern) + 'WILD + 'WILD + (pathname-version pattern)) + pattern)))) (let ((directory-path (directory-pathname pattern))) (map (lambda (pathname) (merge-pathnames pathname directory-path)) -- 2.25.1