Retain inheritance information for major modes.

diff --git a/v7/src/edwin/modes.scm b/v7/src/edwin/modes.scm
index 1032a73e2f5ff80770faa2a70f1cffa1bf0bb584..ccfe0de5bf604f112ac078ac7493015ec723ee1c 100644 (file)
--- 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))
 \f
 (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))))))))
+\f
 (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