142 lines
4.1 KiB
Scheme
142 lines
4.1 KiB
Scheme
#| -*-Scheme-*-
|
||
|
||
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
||
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
||
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
||
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
||
|
||
This file is part of MIT/GNU Scheme.
|
||
|
||
MIT/GNU Scheme is free software; you can redistribute it and/or modify
|
||
it under the terms of the GNU General Public License as published by
|
||
the Free Software Foundation; either version 2 of the License, or (at
|
||
your option) any later version.
|
||
|
||
MIT/GNU Scheme is distributed in the hope that it will be useful, but
|
||
WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
General Public License for more details.
|
||
|
||
You should have received a copy of the GNU General Public License
|
||
along with MIT/GNU Scheme; if not, write to the Free Software
|
||
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
||
USA.
|
||
|
||
|#
|
||
|
||
;;;; Modes
|
||
|
||
|
||
|
||
(define-structure (mode
|
||
(constructor %make-mode
|
||
(name major? display-name super-mode
|
||
%description initialization comtabs))
|
||
(print-procedure
|
||
(standard-print-method 'MODE
|
||
(lambda (mode)
|
||
(cons (mode-name mode)
|
||
(if (mode-major? mode)
|
||
'()
|
||
(list '(minor))))))))
|
||
(name #f read-only #t)
|
||
major?
|
||
display-name
|
||
super-mode
|
||
%description
|
||
initialization
|
||
(comtabs #f read-only #t))
|
||
|
||
(define (make-mode name major? display-name super-mode description
|
||
initialization)
|
||
(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) '())))
|
||
(let ((mode (string-table-get editor-modes sname))
|
||
(description (doc-string->posn sname description)))
|
||
(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))
|
||
|
||
(define (name->mode name #!optional if-undefined)
|
||
(let ((sname (symbol->string name)))
|
||
(or (string-table-get editor-modes sname)
|
||
(case (if (default-object? if-undefined) 'INTERN if-undefined)
|
||
((#F) #f)
|
||
((ERROR) (error "Undefined mode:" name))
|
||
((INTERN)
|
||
(make-mode name #t sname #f ""
|
||
(lambda () (error "Undefined mode:" name))))
|
||
|
||
(else
|
||
(error:bad-range-argument if-undefined 'NAME->MODE))))))
|
||
|
||
(define (->mode object)
|
||
(if (mode? object)
|
||
object
|
||
(name->mode object)))
|
||
|
||
(define (major-mode? object)
|
||
(and (mode? object)
|
||
(mode-major? object)))
|
||
|
||
(define (minor-mode? object)
|
||
(and (mode? object)
|
||
(not (mode-major? object))))
|
||
|
||
(define (minor-mode-comtab mode)
|
||
(car (mode-comtabs mode)))
|
||
|
||
(define (mode-description mode)
|
||
(let ((desc (mode-%description mode)))
|
||
(if (description? 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))))))
|