  -*- Mode : LISP ; Package : STEVE ;  : CL ;  -*-

Copyright ( c ) May 1983 by  
  and Massachusetts Institute of Technology .
;Permission to copy all or part of this material is granted, provided
  that the copies are not made or distributed for resale , the MIT
; copyright notice and reference to the source file and the software
; distribution version appear, and that notice is given that copying
  is by permission of Massachusetts Institute of Technology .
;
Major and minor mode functions for  .
;

;;; A major mode must have a variable *MODE-bindings* containing the
;;; *editor-bindings* for that mode. Also *MODE-syntax* is local-bound
;;; to the variable syntax-table.

(defstruct (mode (:conc-name mode-))
  name
  superior
  ;:inferiors ;Would this be useful?
  keys
  syntax
  variables)

(defun (:mode fs:file-attribute-bindings) (pathname kwd mode)
  ;; Note: mode can be a symbol or string.
  ;; (setq mode (lookup-mode mode))
  (loop for (var value . crap) on (major-mode-variables mode) by #'cddr
        collect var into vars
        collect value into values
        finally (return (values vars values () ()))))

(defun mode-lookup-symbol (name)
  (intern (string-append (string-upcase name) "-MODE") 'steve))

(defun lookup-mode (name)
  (let ((sym (mode-lookup-symbol name)))
    (and (boundp sym) (symeval sym))))

;Notice that this does not allow for upward propegation of changes.
;Actually that may be reasonable, But the issue should be kept alive
;until decided.
(defsubst derive-syntax (table)
  (copy-syntax-table table))

(defmacro define-mode (name &optional superior keys syntax &restl variables)
  (when (null superior)
    (when (null keys) (setq keys '(make-empty-key-binding-table)))
    (when (null syntax) (setq syntax '(make-empty-syntax-table))))
  `(progn (defunmetax ,(intern (string-append name "-MODE") 'steve) ()
           (major-mode ',name))
          (defparameter
           ,(mode-lookup-symbol name)
           (make-mode
            :name ',name
            :superior ',superior
            ;; :inferiors nil
            :keys ,(if (null keys)
                       `(derive-bindings (mode-keys (lookup-mode ',superior)))
                       `,keys)
            :syntax ,(if (null syntax)
                         `(derive-syntax (mode-syntax
                                          (lookup-mode ',superior)))
                         `,syntax)
            :variables ',(copy-list variables)))))

(defun init-buffer-locals (&optional (buffer *editor-buffer*))
  ;;This creates an environment without a major mode.
  (let ((filename (probe-file (buffer-file-name buffer)))
        (plist))
    (cond ((not (null filename))
           (setq plist (send filename :file-plist))
           (remprop plist :mode)                ;This differs from below.
           (setf (buffer-environment buffer)
                 (calculate-buffer-environment (cdr plist) filename)))
          (t (setf (buffer-environment buffer) (null-load-environment))))
    (setq *context-change-flag* t)))

;;This is really about the same as init-buffer-locals.
;;The only difference is that this sets the major mode too.
(defun initialize-buffer-environment (buffer)
  (let ((filename (probe-file (buffer-file-name buffer)))
        (plist))
    (cond ((not (null filename))
           (setq plist (send filename :file-plist))
           (when (null (get plist :mode))
             (putprop plist (default-major-mode (send filename :type)) :mode))
           (setf (buffer-environment buffer)
                 (calculate-buffer-environment (cdr plist) filename)))
          (t (setf (buffer-environment buffer) (null-load-environment))
             (major-mode (default-major-mode (send (buffer-file-name buffer)
                                                   :type)))))
    (setq *context-change-flag* t)))

(defvar default-major-mode-alist nil)

(defun default-major-mode (file-type)
  (loop for (type mode) in default-major-mode-alist
        if (string-equal type file-type) return mode
        finally (return "Fundamental")))

(defun major-mode-variables (mode-name &aux (mode (lookup-mode mode-name)))
  (cond ((null mode) (ed-warning "Invalid Mode ~a" mode-name))
        (t (nconc (major-mode-superior-variables mode)
                  (list 'syntax-table (or (mode-syntax mode) syntax-table)
                        '*editor-bindings* (mode-keys mode)
                        '*major-mode* mode-name)))))

(defun major-mode-superior-variables (mode)
  (cond ((null mode) nil)
        (t (let ((vars (cons '*alist* (mode-variables mode)))
                 (shadowable-vars
                  (major-mode-superior-variables
                   (lookup-mode (mode-superior mode)))))
             (nconc (loop for (var value . shit) on shadowable-vars by #'cddr
                          if (not (get vars var))
                          nconc (list var value))
                    (copy-list (cdr vars)))))))

(defun major-mode (&optional (mode-name (mx-prompter #'read-symbol "Mode: "))
                    (buffer *editor-buffer*))
  (init-buffer-locals buffer)
  (loop for (var value . creap) on (major-mode-variables mode-name) by #'cddr
        do (bind-in-buffer buffer var value)))

(defun set-mode-variable (mode variable value)
  (setf (mode-variables mode)
        (list* variable value
               (loop for (var value . shit) on (mode-variables mode) by #'cddr
                     unless (eq var variable)
                     nconc (list var value))))
  (setq *context-change-flag* t)
  variable)

 Package : STEVE ;  : CL ;  -*-
Permission to copy all or part of this material is granted, provided
 copyright notice and reference to the source file and the software
 distribution version appear, and that notice is given that copying


 A major mode must have a variable *MODE-bindings* containing the
 *editor-bindings* for that mode. Also *MODE-syntax* is local-bound
 to the variable syntax-table.
:inferiors ;Would this be useful?
 Note: mode can be a symbol or string.
 (setq mode (lookup-mode mode))
Notice that this does not allow for upward propegation of changes.
Actually that may be reasonable, But the issue should be kept alive
until decided.
 :inferiors nil
This creates an environment without a major mode.
This differs from below.
This is really about the same as init-buffer-locals.
The only difference is that this sets the major mode too.

Copyright ( c ) May 1983 by  
  and Massachusetts Institute of Technology .
  that the copies are not made or distributed for resale , the MIT
  is by permission of Massachusetts Institute of Technology .
Major and minor mode functions for  .


(defstruct (mode (:conc-name mode-))
  name
  superior
  keys
  syntax
  variables)

(defun (:mode fs:file-attribute-bindings) (pathname kwd mode)
  (loop for (var value . crap) on (major-mode-variables mode) by #'cddr
        collect var into vars
        collect value into values
        finally (return (values vars values () ()))))

(defun mode-lookup-symbol (name)
  (intern (string-append (string-upcase name) "-MODE") 'steve))

(defun lookup-mode (name)
  (let ((sym (mode-lookup-symbol name)))
    (and (boundp sym) (symeval sym))))

(defsubst derive-syntax (table)
  (copy-syntax-table table))

(defmacro define-mode (name &optional superior keys syntax &restl variables)
  (when (null superior)
    (when (null keys) (setq keys '(make-empty-key-binding-table)))
    (when (null syntax) (setq syntax '(make-empty-syntax-table))))
  `(progn (defunmetax ,(intern (string-append name "-MODE") 'steve) ()
           (major-mode ',name))
          (defparameter
           ,(mode-lookup-symbol name)
           (make-mode
            :name ',name
            :superior ',superior
            :keys ,(if (null keys)
                       `(derive-bindings (mode-keys (lookup-mode ',superior)))
                       `,keys)
            :syntax ,(if (null syntax)
                         `(derive-syntax (mode-syntax
                                          (lookup-mode ',superior)))
                         `,syntax)
            :variables ',(copy-list variables)))))

(defun init-buffer-locals (&optional (buffer *editor-buffer*))
  (let ((filename (probe-file (buffer-file-name buffer)))
        (plist))
    (cond ((not (null filename))
           (setq plist (send filename :file-plist))
           (setf (buffer-environment buffer)
                 (calculate-buffer-environment (cdr plist) filename)))
          (t (setf (buffer-environment buffer) (null-load-environment))))
    (setq *context-change-flag* t)))

(defun initialize-buffer-environment (buffer)
  (let ((filename (probe-file (buffer-file-name buffer)))
        (plist))
    (cond ((not (null filename))
           (setq plist (send filename :file-plist))
           (when (null (get plist :mode))
             (putprop plist (default-major-mode (send filename :type)) :mode))
           (setf (buffer-environment buffer)
                 (calculate-buffer-environment (cdr plist) filename)))
          (t (setf (buffer-environment buffer) (null-load-environment))
             (major-mode (default-major-mode (send (buffer-file-name buffer)
                                                   :type)))))
    (setq *context-change-flag* t)))

(defvar default-major-mode-alist nil)

(defun default-major-mode (file-type)
  (loop for (type mode) in default-major-mode-alist
        if (string-equal type file-type) return mode
        finally (return "Fundamental")))

(defun major-mode-variables (mode-name &aux (mode (lookup-mode mode-name)))
  (cond ((null mode) (ed-warning "Invalid Mode ~a" mode-name))
        (t (nconc (major-mode-superior-variables mode)
                  (list 'syntax-table (or (mode-syntax mode) syntax-table)
                        '*editor-bindings* (mode-keys mode)
                        '*major-mode* mode-name)))))

(defun major-mode-superior-variables (mode)
  (cond ((null mode) nil)
        (t (let ((vars (cons '*alist* (mode-variables mode)))
                 (shadowable-vars
                  (major-mode-superior-variables
                   (lookup-mode (mode-superior mode)))))
             (nconc (loop for (var value . shit) on shadowable-vars by #'cddr
                          if (not (get vars var))
                          nconc (list var value))
                    (copy-list (cdr vars)))))))

(defun major-mode (&optional (mode-name (mx-prompter #'read-symbol "Mode: "))
                    (buffer *editor-buffer*))
  (init-buffer-locals buffer)
  (loop for (var value . creap) on (major-mode-variables mode-name) by #'cddr
        do (bind-in-buffer buffer var value)))

(defun set-mode-variable (mode variable value)
  (setf (mode-variables mode)
        (list* variable value
               (loop for (var value . shit) on (mode-variables mode) by #'cddr
                     unless (eq var variable)
                     nconc (list var value))))
  (setq *context-change-flag* t)
  variable)
