From 5f3f8284bb9ed1879086197d8b082fc8079739e4 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 14 Jan 1999 18:25:09 +0000
Subject: [PATCH] Fix PATHNAME-DEFAULT-MODE so that application of
 auto-mode-alist ignores any encoding suffixes.

---
 v7/src/edwin/dosfile.scm | 14 ++++----------
 v7/src/edwin/fileio.scm  | 35 ++++++++++++++++++++---------------
 v7/src/edwin/unix.scm    | 14 ++++----------
 3 files changed, 28 insertions(+), 35 deletions(-)

diff --git a/v7/src/edwin/dosfile.scm b/v7/src/edwin/dosfile.scm
index 2ac4ab512..61b86f5a0 100644
--- a/v7/src/edwin/dosfile.scm
+++ b/v7/src/edwin/dosfile.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: dosfile.scm,v 1.22 1999/01/02 06:11:34 cph Exp $
+;;; $Id: dosfile.scm,v 1.23 1999/01/14 18:25:09 cph Exp $
 ;;;
 ;;; Copyright (c) 1994-1999 Massachusetts Institute of Technology
 ;;;
@@ -41,13 +41,13 @@ Includes the new backup.  Must be > 0."
   2
   (lambda (n) (and (exact-integer? n) (> n 0))))
 
-(define dos/encoding-pathname-types
+(define os/encoding-pathname-types
   '("gz" "bf" "ky"))
 
 (define dos/backup-suffixes
   (cons "~"
 	(map (lambda (type) (string-append "~." type))
-	     dos/encoding-pathname-types)))
+	     os/encoding-pathname-types)))
 
 (define-variable completion-ignored-extensions
   "Completion ignores filenames ending in any string in this list."
@@ -207,7 +207,7 @@ Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'."
       (lambda ()
 	(if (dos/fs-long-filenames? truename)
 	    (let ((type (pathname-type truename)))
-	      (if (member type dos/encoding-pathname-types)
+	      (if (member type os/encoding-pathname-types)
 		  (values (pathname-new-type truename #f)
 			  (string-append "~." type))
 		  (values truename "~")))
@@ -407,12 +407,6 @@ Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'."
   truename buffer
   #f)
 
-(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 #f)))
-	type)))
-
 (define (os/completion-ignore-filename? filename)
   (or (os/backup-filename? filename)
       (os/auto-save-filename? filename)
diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm
index 1fedcbdae..31742857e 100644
--- a/v7/src/edwin/fileio.scm
+++ b/v7/src/edwin/fileio.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: fileio.scm,v 1.144 1999/01/02 06:11:34 cph Exp $
+;;; $Id: fileio.scm,v 1.145 1999/01/14 18:24:58 cph Exp $
 ;;;
 ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
 ;;;
@@ -231,21 +231,26 @@ of the predicates is satisfied, the file is written in the usual way."
 			   (if (re-search-forward "[ \t]*;" m end false)
 			       (re-match-start 0)
 			       end)))))))))))
-
+
 (define (pathname-default-mode pathname buffer)
-  (or (let ((filename (->namestring pathname)))
-	(let loop ((types (ref-variable auto-mode-alist buffer)))
-	  (and (not (null? types))
-	       (if (re-string-match (caar types) filename)
-		   (->mode (cdar types))
-		   (loop (cdr types))))))
-      (let ((type (os/pathname-type-for-mode pathname)))
-	(and (string? type)
-	     (let loop ((types (ref-variable file-type-to-major-mode buffer)))
-	       (and (not (null? types))
-		    (if (string-ci=? type (caar types))
-			(->mode (cdar types))
-			(loop (cdr types)))))))))
+  (let ((pathname
+	 (if (member (pathname-type pathname) os/encoding-pathname-types)
+	     (->namestring (pathname-new-type pathname #f))
+	     pathname)))
+    (or (let ((filename (->namestring pathname)))
+	  (let loop ((types (ref-variable auto-mode-alist buffer)))
+	    (and (not (null? types))
+		 (if (re-string-match (caar types) filename)
+		     (->mode (cdar types))
+		     (loop (cdr types))))))
+	(let ((type (pathname-type pathname)))
+	  (and (string? type)
+	       (let loop
+		   ((types (ref-variable file-type-to-major-mode buffer)))
+		 (and (not (null? types))
+		      (if (string-ci=? type (caar types))
+			  (->mode (cdar types))
+			  (loop (cdr types))))))))))
 
 (define (string->mode-alist? object)
   (and (alist? object)
diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm
index 2fb9c26eb..6f1aa930e 100644
--- a/v7/src/edwin/unix.scm
+++ b/v7/src/edwin/unix.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: unix.scm,v 1.88 1999/01/02 06:11:34 cph Exp $
+;;; $Id: unix.scm,v 1.89 1999/01/14 18:25:03 cph Exp $
 ;;;
 ;;; Copyright (c) 1989-1999 Massachusetts Institute of Technology
 ;;;
@@ -161,7 +161,7 @@ Includes the new backup.  Must be > 0."
   (call-with-values
       (lambda ()
 	(let ((type (pathname-type truename)))
-	  (if (member type unix/encoding-pathname-types)
+	  (if (member type os/encoding-pathname-types)
 	      (values (pathname-new-type truename #f)
 		      (string-append "~." type))
 	      (values truename "~"))))
@@ -235,13 +235,13 @@ Includes the new backup.  Must be > 0."
 	      (directory-channel-close channel)
 	      result))))))
 
-(define unix/encoding-pathname-types
+(define os/encoding-pathname-types
   '("Z" "gz" "KY" "ky" "bf"))
 
 (define unix/backup-suffixes
   (cons "~"
 	(map (lambda (type) (string-append "~." type))
-	     unix/encoding-pathname-types)))
+	     os/encoding-pathname-types)))
 
 (define (os/backup-filename? filename)
   (let ((end (string-length filename)))
@@ -274,12 +274,6 @@ Includes the new backup.  Must be > 0."
 						  (fix:+ index 1)
 						  suffix)))))))))
 
-(define (os/pathname-type-for-mode pathname)
-  (let ((type (pathname-type pathname)))
-    (if (member type unix/encoding-pathname-types)
-	(pathname-type (->namestring (pathname-new-type pathname false)))
-	type)))
-
 (define (os/completion-ignore-filename? filename)
   (and (not (file-test-no-errors file-directory? filename))
        (there-exists? (ref-variable completion-ignored-extensions)
-- 
2.25.1