;; See the file LICENSE for the full license governing this code.

;;;;
;;; The Modes
;;;;

(defun fi::kill-all-local-variables ()
  ;; don't kill the input ring, which can be very useful
  (let ((input-ring fi::input-ring)
	(input-ring-yank-pointer fi::input-ring-yank-pointer)
	(last-input-search-string fi::last-input-search-string)
	(last-command-was-successful-search
	 fi::last-command-was-successful-search))
    (kill-all-local-variables)
    (setq fi::input-ring input-ring)
    (setq fi::input-ring-yank-pointer input-ring-yank-pointer)
    (setq fi::last-input-search-string last-input-search-string)
    (setq fi::last-command-was-successful-search
      last-command-was-successful-search)))

(defun fi:inferior-common-lisp-mode (&optional mode-hook &rest mode-hook-args)
  "Major mode for interacting with Common Lisp subprocesses.
The keymap for this mode is bound to fi:inferior-common-lisp-mode-map:

<font face=\"Courier New\">\\{fi:inferior-common-lisp-mode-map}</font>
Entry to this mode runs the following hooks:

	fi:lisp-mode-hook
	fi:subprocess-mode-hook
	fi:inferior-common-lisp-mode-hook

in the above order.

When calling from a program, arguments are MODE-HOOK and MODE-HOOK-ARGS,
the former is applied to the latter just after killing all local variables
but before doing any other mode setup."
  (interactive)
  (fi::kill-all-local-variables)
  (if mode-hook (apply mode-hook mode-hook-args))
  (setq major-mode 'fi:inferior-common-lisp-mode)
  (setq mode-name "Inferior Common Lisp")
  (set-syntax-table fi:lisp-mode-syntax-table)
  (fi::lisp-subprocess-mode-variables)
  (fi::initialize-mode-map 'fi:inferior-common-lisp-mode-map
			   'fi:inferior-common-lisp-mode-super-key-map
			   'sub-lisp)
  (use-local-map fi:inferior-common-lisp-mode-map)
  (setq fi:lisp-indent-hook-property 'fi:common-lisp-indent-hook)
  (run-mode-hooks 'fi:lisp-mode-hook 'fi:subprocess-mode-hook
	     'fi:inferior-common-lisp-mode-hook))

(defun fi:inferior-franz-lisp-mode (&optional mode-hook &rest mode-hook-args)
  "Major mode for interacting with Franz Lisp subprocesses.
The keymap for this mode is bound to fi:inferior-franz-lisp-mode-map:

<font face=\"Courier New\">\\{fi:inferior-franz-lisp-mode-map}</font>
Entry to this mode runs the following hooks:

	fi:lisp-mode-hook
	fi:subprocess-mode-hook
	fi:inferior-franz-lisp-mode-hook

in the above order.

When calling from a program, arguments are MODE-HOOK and MODE-HOOK-ARGS,
the former is applied to the latter just after killing all local variables
but before doing any other mode setup."
  (interactive)
  (fi::kill-all-local-variables)
  (if mode-hook (apply mode-hook mode-hook-args))
  (setq major-mode 'fi:inferior-franz-lisp-mode)
  (setq mode-name "Inferior Franz Lisp")
  (set-syntax-table fi:lisp-mode-syntax-table)
  (fi::lisp-subprocess-mode-variables)
  (fi::initialize-mode-map 'fi:inferior-franz-lisp-mode-map
			   'fi:inferior-franz-lisp-mode-super-key-map
			   'sub-lisp)
  (use-local-map fi:inferior-franz-lisp-mode-map)
  (setq fi:lisp-indent-hook-property 'fi:franz-lisp-indent-hook)
  (run-mode-hooks 'fi:lisp-mode-hook 'fi:subprocess-mode-hook
	     'fi:inferior-franz-lisp-mode-hook))

(defun fi:lisp-listener-mode (&optional mode-hook)
  "Major mode for interacting with Common Lisp over a socket.
The keymap for this mode is bound to fi:lisp-listener-mode-map:

<font face=\"Courier New\">\\{fi:lisp-listener-mode-map}</font>
Entry to this mode runs the following hooks:

	fi:lisp-mode-hook
	fi:subprocess-mode-hook
	fi:lisp-listener-mode-hook

in the above order.

When calling from a program, argument is MODE-HOOK,
which is funcall'd just after killing all local variables but before doing
any other mode setup."
  (interactive)
  (fi::kill-all-local-variables)
  (if mode-hook (funcall mode-hook))
  (setq major-mode 'fi:lisp-listener-mode)
  (setq mode-name "TCP Common Lisp")
  (set-syntax-table fi:lisp-mode-syntax-table)
  (fi::lisp-subprocess-mode-variables)
  (fi::initialize-mode-map 'fi:lisp-listener-mode-map
			   'fi:lisp-listener-mode-super-key-map
			   'tcp-lisp)
  (use-local-map fi:lisp-listener-mode-map)
  (setq fi:lisp-indent-hook-property 'fi:common-lisp-indent-hook)
  (run-mode-hooks 'fi:lisp-mode-hook 'fi:subprocess-mode-hook
	     'fi:lisp-listener-mode-hook))

(defun fi:common-lisp-mode (&optional mode-hook)
  "Major mode for editing Lisp code to run in Common Lisp.
The keymap for this mode is bound to fi:common-lisp-mode-map:

<font face=\"Courier New\">\\{fi:common-lisp-mode-map}</font>
Entry to this mode runs the following hooks:

	fi:lisp-mode-hook
	fi:common-lisp-mode-hook

in the above order.

When calling from a program, argument is MODE-HOOK,
which is funcall'd just after killing all local variables but before doing
any other mode setup."
  (interactive)
  (kill-all-local-variables)
  (if mode-hook (funcall mode-hook))
  (setq major-mode 'fi:common-lisp-mode)
  (setq mode-name "Common Lisp")
  (set-syntax-table fi:lisp-mode-syntax-table)
  (fi::lisp-edit-mode-setup)
  (fi:parse-mode-line-and-package)
  (fi::initialize-mode-map 'fi:common-lisp-mode-map)
  (use-local-map fi:common-lisp-mode-map)
  (setq fi::process-name fi::common-lisp-backdoor-main-process-name)
  (setq fi:lisp-indent-hook-property 'fi:common-lisp-indent-hook)
  (run-mode-hooks 'fi:lisp-mode-hook 'fi:common-lisp-mode-hook))

(add-hook 'fi:common-lisp-mode-hook
	  (function
	   (lambda ()
	     (when (not (fi:member-equal "; pkg:" mode-line-process))
	       (setq mode-line-process
		 (append mode-line-process
			 '((fi:package ("; pkg:" fi:package))))))
	     (when (not (fi:member-equal "; rt:" mode-line-process))
	       (setq mode-line-process
		 (append mode-line-process
			 '((fi:readtable ("; rt:" fi:readtable))))))))
	  "*The initial value of this hook, which is run whenever a Lisp mode is
entered, causes the `package' and readtable (if any) to be displayed in the
mode line.  It uses MODE-LINE-PROCESS, which has no use in non-subprocess
buffers.")

(defadvice lisp-mode (around ad-lisp-mode-use-fi:common-lisp-mode first
			     (&optional mode-hook)
			     activate) 
  (fi:common-lisp-mode mode-hook))

(ad-activate 'lisp-mode)

(defalias 'common-lisp-mode 'fi:common-lisp-mode
  "See fi:common-lisp-mode.  This function is here so that set-auto-mode
will go into the FI Common Lisp mode when ``mode: common-lisp'' appears in
the file modeline.")

(defun fi:franz-lisp-mode (&optional mode-hook)
  "Major mode for editing Lisp code to run in Franz Lisp.
The keymap for this mode is bound to fi:franz-lisp-mode-map:

<font face=\"Courier New\">\\{fi:franz-lisp-mode-map}</font>
Entry to this mode runs the following hooks:

	fi:lisp-mode-hook
	fi:franz-lisp-mode-hook

in the above order.

When calling from a program, argument is MODE-HOOK,
which is funcall'd just after killing all local variables but before doing
any other mode setup."
  (interactive)
  (kill-all-local-variables)
  (if mode-hook (funcall mode-hook))
  (setq major-mode 'fi:franz-lisp-mode)
  (setq mode-name "Franz Lisp")
  (set-syntax-table fi:lisp-mode-syntax-table)
  (fi::lisp-edit-mode-setup)
  (fi:parse-mode-line-and-package)
  (fi::initialize-mode-map 'fi:franz-lisp-mode-map)
  (use-local-map fi:franz-lisp-mode-map)
  (setq fi::process-name fi:franz-lisp-process-name)
  (setq fi:lisp-indent-hook-property 'fi:franz-lisp-indent-hook)
  (run-mode-hooks 'fi:lisp-mode-hook 'fi:franz-lisp-mode-hook))

(defun fi:emacs-lisp-mode (&optional mode-hook)
  "Major mode for editing Lisp code to run in Emacs Lisp.
The keymap for this mode is bound to fi:emacs-lisp-mode-map:

<font face=\"Courier New\">\\{fi:emacs-lisp-mode-map}</font>
Entry to this mode runs the fi:emacs-lisp-mode-hook hook.

When calling from a program, argument is MODE-HOOK,
which is funcall'd just after killing all local variables but before doing
any other mode setup."
  (interactive)
  (kill-all-local-variables)
  (if mode-hook (funcall mode-hook))
  (setq major-mode 'fi:emacs-lisp-mode)
  (setq mode-name "Emacs Lisp")
  (set-syntax-table fi:emacs-lisp-mode-syntax-table)
  (fi::lisp-edit-mode-setup)
  (fi::initialize-mode-map 'fi:emacs-lisp-mode-map)
  (use-local-map fi:emacs-lisp-mode-map)
  (setq fi:lisp-indent-hook-property 'fi:emacs-lisp-indent-hook)
  (run-mode-hooks 'fi:emacs-lisp-mode-hook))

(defun fi::lisp-edit-mode-setup ()
  (fi::lisp-mode-setup-common))

(defun fi::lisp-subprocess-mode-variables ()
  (make-local-variable 'fi:subprocess-mode)
  (setq fi:subprocess-mode t)
  (fi::lisp-mode-setup-common))

(defun fi::lisp-mode-setup-common ()
  ;; not needed for Emacs Lisp mode, but ...
  (setq fi:in-package-regexp fi:default-in-package-regexp)

  (setq local-abbrev-table lisp-mode-abbrev-table)

  (make-local-variable 'paragraph-start)
  (setq paragraph-start (concat "^$\\|" page-delimiter))
  (make-local-variable 'paragraph-separate)
  (setq paragraph-separate paragraph-start)
  (make-local-variable 'comment-start)
  (setq comment-start ";")
  (make-local-variable 'comment-start-skip)
  (setq comment-start-skip ";+[ \t]*")
  (make-local-variable 'comment-column)
  (setq comment-column 40)

  (if fi:lisp-do-indentation
      (progn
	(make-local-variable 'fill-paragraph-function)
	(setq fill-paragraph-function 'fi:fill-paragraph)
	
	(when fi:auto-fill
	  (setq fill-column 75)
	  (auto-fill-mode 1)
	  (make-local-variable 'auto-fill-function)
	  (setq auto-fill-function 'fi::do-auto-fill))
  
	(make-local-variable 'indent-line-function)
	(setq indent-line-function 'fi:lisp-indent-line)

	(make-local-variable 'comment-indent-function)
	(setq comment-indent-function 'fi:lisp-comment-indent)

	(make-local-variable 'parse-sexp-ignore-comments)
	;; It used to be true that this variable must be `nil' when
	;; comments end in newlines.  However, it seems this limitation was
	;; removed some time around the start of 1994, so now we'll try
	;; setting it true. - smh 29jun95
	(setq parse-sexp-ignore-comments t)

	(setq fi::lisp-most-recent-parse-result (list 0 0 0 0 nil nil nil 0))
	(setq fi::calculate-lisp-indent-state-temp (list 0 0 0 nil nil nil 0))
	(setq fi::lisp-indent-state-temp (list nil nil nil nil nil nil nil)))
    ;; the GNU style
    (lisp-mode-variables t))
  
  (when fi::menubar-initialization (funcall fi::menubar-initialization)))

(defvar fi:default-package
    "user"
  "*The name of the package to use as the default package, if there is no
package specification in the mode line.  See fi:parse-mode-line-and-package
for more information.")

(defvar fi::do-parse-mode-line-and-package t)

(defun fi:parse-mode-line-and-package ()
  "Determine the current package in which the buffer is defined.
The buffer's IN-PACKAGE form and the -*- mode line are parsed for this
information.  This function is automatically called when a Common Lisp
source file is visited, but may be executed explicitly to re-parse the
package.

When using Allegro CL 4.2 or later, the ``Readtable: '' can be used to name
the readtable used for evaluations given to Lisp from emacs."
  (interactive)
  (when fi::do-parse-mode-line-and-package
    (setq fi:readtable (fi::parse-mode-line "readtable"))
    (setq fi:package
      (fi::parse-mode-line "package" fi:default-package t
			   'fi::parse-package-from-buffer t))))

(defun fi::parse-mode-line (key
			    &optional default-value messagep fail-hook
				      list-value-ok)
  (save-excursion
    (let ((case-fold-search t)
	  (search-string (format "%s:" key))
	  value found start end)
      (goto-char (point-min))
      (when (and (search-forward "-*-"
				 (save-excursion (end-of-line) (point))
				 t)
		 (progn
		   (skip-chars-forward " \t")
		   (setq start (point))
		   (search-forward "-*-"
				   (save-excursion (end-of-line) (point))
				   t)))
	(forward-char -3)
	(skip-chars-backward " \t")
	(setq end (point))
	(goto-char start)

	(when (search-forward ":" end t)
	  (goto-char start)
	  (when (search-forward search-string end t)
	    (skip-chars-forward " \t")
	    (setq start (point))
	    (if (> start end) (setq end start))
	    (if (search-forward ";" end t)
		(forward-char -1)
	      (goto-char end))
	    (skip-chars-backward " \t")
	    (cond
	     ((>= start (point))
	      (setq value default-value))
	     (t
	      (let ((val
		     (if (and list-value-ok
			      (= (string-to-char "(")
				 (char-after start)))
			 (buffer-substring (+ 1 start)
					   (point))
		       (buffer-substring start (point)))))
		(setq found t)
		(setq value
		  (downcase
		   (symbol-name (car (read-from-string val)))))))))))
      (when (and (not found) fail-hook)
	(goto-char (point-min))
	(let ((val (funcall fail-hook)))
	  (when val
	    (setq found t value val))))
      (unless found (setq value default-value))
      (when messagep
	(if found
	    (message "%s specification is `%s'" key value)
	  (message "using default %s specification of `%s'"
		   key value)))
      value)))

(defvar fi::*in-package-regexp*
    "^(\\(cl:\\|common-lisp:\\)?in-package[\t ]*#?")

(defun fi::parse-package-from-buffer (&optional current-point
						backward
						post-init)
  (when (not current-point) (goto-char (point-min)))
  (let* ((search (if backward 're-search-backward 're-search-forward))
	 (pos (funcall search fi::*in-package-regexp* nil t))
	 value)
    ;; find the `in-package' form, and snarf the package
    ;; that way
    (when pos
      (let* ((start (match-end 0))
	     (end (progn (search-forward ")" nil t)
			 (match-beginning 0)))
	     (p-string (buffer-substring start end))
	     (p (car (read-from-string p-string))))
	(setq value
	  (cond ((symbolp p)
		 (if (= (elt (symbol-name p) 0) ?:)
		     (substring (symbol-name p) 1)
		   (symbol-name p)))
		((and (consp p)
		      (eq 'quote (car p))
		      (symbolp (car (cdr p))))
		 (let ((name (symbol-name (car (cdr p)))))
		   (if (= (elt name 0) ?:)
		       (substring name 1)
		     name)))
		((stringp p) p)))))
    (when (and (null post-init)
	       (funcall search fi::*in-package-regexp* nil t))
      (setq fi::multiple-in-packages t))
    value))

(defun fi::find-tag-common-lisp ()
  ;; This raises the intelligence of the default tag in find-tag by
  ;; removing explicit package qualifiers, rarely found in the target
  ;; source file.  See find-tag-tag in lisp/progmodes/etags.el for
  ;; the defaulting mechanism.  From smh, 8/14/2000.
  (let ((default (find-tag-default)))
    (when default
      (let ((n (cl-position ?: default :from-end t)))
	(if n
	    (cl-subseq default (1+ n))
	  default)))))

(dolist (m '(fi:common-lisp-mode
	     fi:inferior-common-lisp-mode
	     fi:lisp-listener-mode
	     fi:definition-mode))
  (put m 'find-tag-default-function 'fi::find-tag-common-lisp))

;;;;
;;; Initializations
;;;;

;; the following is because the data associated with auto-mode-alist
;; is put in text space when xemacs is built, and is by default read-only.
(setq auto-mode-alist (copy-alist auto-mode-alist))

(defun fi::def-auto-mode (string mode)
  (let ((xx (assoc string auto-mode-alist)))
    (if xx
	(rplacd xx mode)
      (setq auto-mode-alist
	(cons (cons string mode) auto-mode-alist)))))

(fi::def-auto-mode "\\.l$" 'fi:franz-lisp-mode)
;;
(let ((list fi:common-lisp-file-types))
  (while list
    (fi::def-auto-mode (concat "\\" (car list) "$")
	'fi:common-lisp-mode)
    (setq list (cdr list))))

(defvar fi:define-emacs-lisp-mode nil
  "*If non-nil, then use the FI supplied mode for editing .el files.")

(when fi:define-emacs-lisp-mode
  (fi::def-auto-mode "\\.el$" 'fi:emacs-lisp-mode)
  (fi::def-auto-mode "[]>:/]\\..*emacs" 'fi:emacs-lisp-mode))

;;;; the syntax tables for Lisp and Emacs Lisp

(if (not fi:emacs-lisp-mode-syntax-table)
    (let ((i 0))
      (setq fi:emacs-lisp-mode-syntax-table (make-syntax-table))
      (while (< i ?0)
	(modify-syntax-entry i "_   " fi:emacs-lisp-mode-syntax-table)
	(setq i (1+ i)))
      (setq i (1+ ?9))
      (while (< i ?A)
	(modify-syntax-entry i "_   " fi:emacs-lisp-mode-syntax-table)
	(setq i (1+ i)))
      (setq i (1+ ?Z))
      (while (< i ?a)
	(modify-syntax-entry i "_   " fi:emacs-lisp-mode-syntax-table)
	(setq i (1+ i)))
      (setq i (1+ ?z))
      (while (< i 128)
	(modify-syntax-entry i "_   " fi:emacs-lisp-mode-syntax-table)
	(setq i (1+ i)))
      (modify-syntax-entry ?  "    " fi:emacs-lisp-mode-syntax-table)
      (modify-syntax-entry ?\t "    " fi:emacs-lisp-mode-syntax-table)
      (modify-syntax-entry ?\n ">   " fi:emacs-lisp-mode-syntax-table)
      (modify-syntax-entry ?\f ">   " fi:emacs-lisp-mode-syntax-table)
      (modify-syntax-entry ?\; "<   " fi:emacs-lisp-mode-syntax-table)
      (modify-syntax-entry ?` "'   " fi:emacs-lisp-mode-syntax-table)
      (modify-syntax-entry ?' "'   " fi:emacs-lisp-mode-syntax-table)
      (modify-syntax-entry ?, "'   " fi:emacs-lisp-mode-syntax-table)
      (modify-syntax-entry ?. "'   " fi:emacs-lisp-mode-syntax-table)
      (modify-syntax-entry ?# "'   " fi:emacs-lisp-mode-syntax-table)
      (modify-syntax-entry ?\" "\"    " fi:emacs-lisp-mode-syntax-table)
      (modify-syntax-entry ?\\ "\\   " fi:emacs-lisp-mode-syntax-table)
      (modify-syntax-entry ?\( "()  " fi:emacs-lisp-mode-syntax-table)
      (modify-syntax-entry ?\) ")(  " fi:emacs-lisp-mode-syntax-table)
      (modify-syntax-entry ?\[ "(]  " fi:emacs-lisp-mode-syntax-table)
      (modify-syntax-entry ?\] ")[  " fi:emacs-lisp-mode-syntax-table)))

(if (not fi:lisp-mode-syntax-table)
    (progn
      (setq fi:lisp-mode-syntax-table
	(copy-syntax-table fi:emacs-lisp-mode-syntax-table))
      ;;(modify-syntax-entry ?_   "w   " fi:lisp-mode-syntax-table)
      ;;(modify-syntax-entry ?-   "w   " fi:lisp-mode-syntax-table)
      (modify-syntax-entry ?*   "w   " fi:lisp-mode-syntax-table)
      ;; The next syntax entry doesn't work with these forms:
      ;;  `,.foo
      ;;  #.foo
      ;; but it works better with variables with .'s in them
      (modify-syntax-entry ?. "w   " fi:lisp-mode-syntax-table)

      ;; [spr33655] from Jason S. Cornez
      ;;; can't do this because it causes indentation of #+/#- forms to be
      ;;; off
      ;;(modify-syntax-entry ?\# ". 14" fi:lisp-mode-syntax-table)
      ;;(modify-syntax-entry ?\| ". 23b" fi:lisp-mode-syntax-table)

      (modify-syntax-entry ?\[ "_   " fi:lisp-mode-syntax-table)
      (modify-syntax-entry ?\] "_   " fi:lisp-mode-syntax-table)))
