From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 9 Jan 1992 17:47:27 +0000 (+0000)
Subject: * Change MAKE-MODE to accept parent mode rather than list of comtabs.
X-Git-Tag: 20090517-FFI~10013
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a84605f78d5ca8cebf890d14b19cc85f167849bc;p=mit-scheme.git

* Change MAKE-MODE to accept parent mode rather than list of comtabs.

* Rename MODE-COMTAB to MINOR-MODE-COMTAB.

* New procedures MINOR-MODE? and MAJOR-MODE?.

* Eliminate NAME->MODE; use ->MODE instead.
---

diff --git a/v7/src/edwin/autold.scm b/v7/src/edwin/autold.scm
index 574351885..a90fa59bd 100644
--- a/v7/src/edwin/autold.scm
+++ b/v7/src/edwin/autold.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autold.scm,v 1.50 1991/05/02 01:12:03 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autold.scm,v 1.51 1992/01/09 17:46:01 cph Exp $
 ;;;
-;;;	Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -82,9 +82,7 @@
     (make-mode name
 	       true
 	       display-name
-	       (if super-mode-name
-		   (mode-comtabs (name->mode super-mode-name))
-		   '())
+	       (and super-mode-name (->mode super-mode-name))
 	       description
 	       (make-autoloading-procedure library-name
 					   (lambda ()
@@ -99,7 +97,7 @@
     (make-mode name
 	       false
 	       display-name
-	       '()
+	       false
 	       description
 	       (make-autoloading-procedure library-name
 					   (lambda ()
diff --git a/v7/src/edwin/buffer.scm b/v7/src/edwin/buffer.scm
index f701b3bd5..7eb26d003 100644
--- a/v7/src/edwin/buffer.scm
+++ b/v7/src/edwin/buffer.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.149 1991/11/06 21:55:55 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.150 1992/01/09 17:45:32 cph Exp $
 ;;;
-;;;	Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -519,7 +519,7 @@ The buffer is guaranteed to be deselected at that time."
   (memq mode (buffer-minor-modes buffer)))
 
 (define (enable-buffer-minor-mode! buffer mode)
-  (if (not (and (mode? mode) (not (mode-major? mode))))
+  (if (not (minor-mode? mode))
       (error:wrong-type-argument mode "minor mode" 'ENABLE-BUFFER-MINOR-MODE!))
   (without-interrupts
    (lambda ()
@@ -528,13 +528,13 @@ The buffer is guaranteed to be deselected at that time."
 	   (begin
 	     (set-cdr! modes (append! (cdr modes) (list mode)))
 	     (set-buffer-comtabs! buffer
-				  (cons (mode-comtab mode)
+				  (cons (minor-mode-comtab mode)
 					(buffer-comtabs buffer)))
 	     (%add-buffer-initialization! buffer (mode-initialization mode))
 	     (buffer-modeline-event! buffer 'BUFFER-MODES)))))))
 
 (define (disable-buffer-minor-mode! buffer mode)
-  (if (not (and (mode? mode) (not (mode-major? mode))))
+  (if (not (minor-mode? mode))
       (error:wrong-type-argument mode "minor mode"
 				 'DISABLE-BUFFER-MINOR-MODE!))
   (without-interrupts
@@ -544,6 +544,6 @@ The buffer is guaranteed to be deselected at that time."
 	   (begin
 	     (set-cdr! modes (delq! mode (cdr modes)))
 	     (set-buffer-comtabs! buffer
-				  (delq! (mode-comtab mode)
+				  (delq! (minor-mode-comtab mode)
 					 (buffer-comtabs buffer)))
 	     (buffer-modeline-event! buffer 'BUFFER-MODES)))))))
\ No newline at end of file
diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm
index a221ba33a..747557339 100644
--- a/v7/src/edwin/fileio.scm
+++ b/v7/src/edwin/fileio.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.103 1991/11/04 20:51:04 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.104 1992/01/09 17:46:59 cph Exp $
 ;;;
-;;;	Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -157,7 +157,8 @@
 		       (assoc-string-ci
 			type
 			(ref-variable file-type-to-major-mode))))))))
-    (and entry (name->mode (cdr entry)))))
+    (and entry
+	 (->mode (cdr entry)))))
 
 (define assoc-string-ci
   (association-procedure string-ci=? car))
diff --git a/v7/src/edwin/macros.scm b/v7/src/edwin/macros.scm
index 641c19975..0931fa96d 100644
--- a/v7/src/edwin/macros.scm
+++ b/v7/src/edwin/macros.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/macros.scm,v 1.53 1991/08/13 20:59:40 newts Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/macros.scm,v 1.54 1992/01/09 17:47:27 cph Exp $
 ;;;
-;;;	Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -186,11 +186,11 @@
 	   (and super-mode-name (canonicalize-name super-mode-name))))
       `(DEFINE ,(mode-name->scheme-name name)
 	 (MAKE-MODE ',name
-		    TRUE
+		    #T
 		    ',(or display-name (symbol->string name))
 		    ,(if super-mode-name
-			 `(MODE-COMTABS (NAME->MODE ',super-mode-name))
-			 ''())
+			 `(->MODE ',super-mode-name)
+			 `#F)
 		    ',description
 		    (LAMBDA ()
 		      ,@(let ((initialization
@@ -209,9 +209,9 @@
     (let ((name (canonicalize-name name)))
       `(DEFINE ,(mode-name->scheme-name name)
 	 (MAKE-MODE ',name
-		    FALSE
+		    #F
 		    ',(or display-name (symbol->string name))
-		    '()
+		    #F
 		    ',description
 		    (LAMBDA ()
 		      ,@(if (null? initialization)
diff --git a/v7/src/edwin/modes.scm b/v7/src/edwin/modes.scm
index d201ecba5..ae3cca313 100644
--- a/v7/src/edwin/modes.scm
+++ b/v7/src/edwin/modes.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modes.scm,v 1.25 1989/08/10 04:42:21 cph Rel $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modes.scm,v 1.26 1992/01/09 17:45:16 cph Exp $
 ;;;
-;;;	Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -46,55 +46,69 @@
 
 (declare (usual-integrations))
 
-(define-named-structure "Mode"
-  name
+(define-structure (mode
+		   (constructor %make-mode (name 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
   major?
-  comtabs
   description
   initialization
-  alist
-  )
+  alist)
 
-(unparser/set-tagged-vector-method!
- %mode-tag
- (unparser/standard-method 'MODE
-   (lambda (state mode)
-     (unparse-object state (mode-name mode))
-     (if (not (mode-major? mode))
-	 (unparse-string state " (minor)")))))
-
-(define (make-mode name major? display-name comtabs description initialization)
+(define (make-mode name major? display-name super-mode description
+		   initialization)
   (let ((mode
-	 (let ((name (symbol->string name)))
-	   (or (string-table-get editor-modes name)
-	       (let ((mode (%make-mode)))
-		 (vector-set! mode mode-index:comtabs (list (make-comtab)))
-		 (string-table-put! editor-modes name mode)
+	 (let ((string (symbol->string name)))
+	   (or (string-table-get editor-modes string)
+	       (let ((mode (%make-mode name (list (make-comtab)))))
+		 (string-table-put! editor-modes string mode)
 		 mode)))))
-    (vector-set! mode mode-index:name name)
-    (vector-set! mode mode-index:display-name display-name)
-    (vector-set! mode mode-index:major? major?)
-    (set-cdr! (vector-ref mode mode-index:comtabs) comtabs)
-    (vector-set! mode mode-index:description description)
-    (vector-set! mode mode-index:initialization initialization)
-    (vector-set! mode mode-index:alist '())
+    (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 description)
+    (set-mode-initialization! mode initialization)
+    (set-mode-alist! mode '())
     mode))
 
-(define-integrable (mode-comtab mode)
-  (car (mode-comtabs mode)))
+(define editor-modes
+  (make-string-table))
+
+(define (->mode object)
+  (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)))))))
 
-(define editor-modes (make-string-table))
+(define (major-mode? object)
+  (and (mode? object)
+       (mode-major? object)))
 
-(define (name->mode name)
-  (let ((name (canonicalize-name name)))
-    (or (string-table-get editor-modes (symbol->string name))
-	(make-mode name
-		   true
-		   (symbol->string name)
-		   '()
-		   ""
-		   (lambda () (error "Undefined mode" name))))))
+(define (minor-mode? object)
+  (and (mode? object)
+       (not (mode-major? object))))
 
-(define (->mode object)
-  (if (mode? object) object (name->mode object)))
\ No newline at end of file
+(define-integrable (minor-mode-comtab mode)
+  (car (mode-comtabs mode)))
\ No newline at end of file