From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 1 Nov 1999 01:17:36 +0000 (+0000)
Subject: Retain inheritance information for major modes.
X-Git-Tag: 20090517-FFI~4429
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d4c5502b1984e2c6e6dedb9574fcd38c7e5a0720;p=mit-scheme.git

Retain inheritance information for major modes.
---

diff --git a/v7/src/edwin/modes.scm b/v7/src/edwin/modes.scm
index 1032a73e2..ccfe0de5b 100644
--- a/v7/src/edwin/modes.scm
+++ b/v7/src/edwin/modes.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: modes.scm,v 1.28 1999/01/02 06:11:34 cph Exp $
+;;; $Id: modes.scm,v 1.29 1999/11/01 01:17:36 cph Exp $
 ;;;
 ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
 ;;;
@@ -23,55 +23,52 @@
 (declare (usual-integrations))
 
 (define-structure (mode
-		   (constructor %make-mode (name comtabs))
+		   (constructor %make-mode
+				(name major? display-name super-mode
+				      %description initialization comtabs))
 		   (print-procedure
 		    (unparser/standard-method 'MODE
 		      (lambda (state mode)
 			(unparse-object state (mode-name mode))
 			(if (not (mode-major? mode))
 			    (unparse-string state " (minor)"))))))
-  (name false read-only true)
-  (comtabs false read-only true)
-  display-name
+  (name #f read-only #t)
   major?
+  display-name
+  super-mode
   %description
   initialization
-  alist)
-
-(define (mode-description mode)
-  (let ((desc (mode-%description mode)))
-    (if (string? desc)
-	desc
-	(let ((new (->doc-string (%symbol->string (mode-name mode))
-				 desc)))
-	  (if new
-	      (set-mode-%description! mode new))
-	  new))))
+  (comtabs #f read-only #t))
 
 (define (make-mode name major? display-name super-mode description
 		   initialization)
-  (let* ((sname (symbol->string name))
-	 (mode
-	  (or (string-table-get editor-modes sname)
-	      (let ((mode (%make-mode name (list (make-comtab)))))
-		(string-table-put! editor-modes sname mode)
-		mode))))
-    (set-mode-display-name! mode display-name)
-    (set-mode-major?! mode major?)
-    (set-cdr! (mode-comtabs mode)
-	      (cond ((not super-mode)
-		     '())
-		    ((mode? super-mode)
-		     (mode-comtabs super-mode))
-		    (else
-		     ;; Old code passes a comtabs list here, so accept
-		     ;; that as a valid argument.  Later, this can be
-		     ;; an error.
-		     super-mode)))
-    (set-mode-%description! mode (doc-string->posn sname description))
-    (set-mode-initialization! mode initialization)
-    (set-mode-alist! mode '())
-    mode))
+  (if (not (or (not super-mode)
+	       (and major? (major-mode? super-mode))))
+      (error:wrong-type-argument super-mode "major mode" 'MAKE-MODE))
+  (let ((sname (symbol->string name))
+	(major? (if major? #t #f))
+	(super-comtabs (if super-mode (mode-comtabs super-mode) '()))
+	(description (doc-string->posn sname description)))
+    (let ((mode (string-table-get editor-modes sname)))
+      (if mode
+	  (begin
+	    (set-mode-major?! mode major?)
+	    (set-mode-display-name! mode display-name)
+	    (set-mode-super-mode! mode super-mode)
+	    (set-cdr! (mode-comtabs mode) super-comtabs)
+	    (set-mode-%description! mode description)
+	    (set-mode-initialization! mode initialization)
+	    mode)
+	  (let ((mode
+		 (%make-mode name
+			     major?
+			     display-name
+			     super-mode
+			     description
+			     initialization
+			     (cons (make-comtab) super-comtabs))))
+	    (string-table-put! editor-modes sname mode)
+	    mode)))))
 
 (define editor-modes
   (make-string-table))
@@ -80,14 +77,11 @@
   (if (mode? object)
       object
       (let ((name (canonicalize-name object)))
-	(or (string-table-get editor-modes (symbol->string name))
-	    (make-mode name
-		       true
-		       (symbol->string name)
-		       false
-		       ""
-		       (lambda () (error "Undefined mode" name)))))))
-
+	(let ((sname (symbol->string name)))
+	  (or (string-table-get editor-modes sname)
+	      (make-mode name #t sname #f ""
+			 (lambda () (error "Undefined mode:" name))))))))
+
 (define (major-mode? object)
   (and (mode? object)
        (mode-major? object)))
@@ -96,5 +90,36 @@
   (and (mode? object)
        (not (mode-major? object))))
 
-(define-integrable (minor-mode-comtab mode)
-  (car (mode-comtabs mode)))
\ No newline at end of file
+(define (minor-mode-comtab mode)
+  (car (mode-comtabs mode)))
+
+(define (mode-description mode)
+  (let ((desc (mode-%description mode)))
+    (if (string? desc)
+	desc
+	(let ((new (->doc-string (symbol->string (mode-name mode)) desc)))
+	  (if new
+	      (set-mode-%description! mode new))
+	  new))))
+
+(define (sub-mode? m1 m2)
+  (if (not (mode? m1))
+      (error:wrong-type-argument m1 "mode" 'SUB-MODE?))
+  (if (not (mode? m2))
+      (error:wrong-type-argument m2 "mode" 'SUB-MODE?))
+  (or (eq? m1 m2)
+      (%strict-sub-mode? m1 m2)))
+
+(define (strict-sub-mode? m1 m2)
+  (if (not (mode? m1))
+      (error:wrong-type-argument m1 "mode" 'STRICT-SUB-MODE?))
+  (if (not (mode? m2))
+      (error:wrong-type-argument m2 "mode" 'STRICT-SUB-MODE?))
+  (%strict-sub-mode? m1 m2))
+
+(define (%strict-sub-mode? m1 m2)
+  (let loop ((m1 m1))
+    (let ((m1 (mode-super-mode m1)))
+      (and m1
+	   (or (eq? m1 m2)
+	       (loop m1))))))
\ No newline at end of file