;;;
;;; Emacs 19 specific code.
;;;
;;; ----------------------------------------------------------------------
;;; This file is part of ILOG Talk.
;;; Inquiries to ILOG S.A.
;;;              9 rue de Verdun, BP 85,
;;;              94253 Gentilly Cedex, France.
;;;
;;; Copyright (c) 1993-1996 by ILOG
;;; ----------------------------------------------------------------------
;;;

(require 'talk-macros)


;; Face creation
;; -------------
;;

(defun tm:create-face (face foreground background bw-style)
  (if (not (find-face face))
      (progn
	(make-face face)
        (if (not (x-color-display-p))
	    (cond
	     ((eq bw-style 'bold) (make-face-bold face))
	     ((eq bw-style 'italic) (make-face-italic face))
	     ((eq bw-style 'bold-italic) (make-face-bold-italic face))
	     (t ()))
	  (cond
	   ((eq background t)
	    (let ((def (face-foreground (find-face 'default))))
	      (if def
		  (set-face-background face def)
		(invert-face face))))
	   ((null background))
	   (t
	    (set-face-background face background)))
	  (if foreground
	      (set-face-foreground face foreground))))))

;; Parameters
;; ----------
;;

(defvar tm:dark-background-p ()
  "Set to T if you want Talk mode to use colors suitable for a dark
Emacs background.")

(defvar tm:auto-raise-window ()
  "When true, windows are automatically raised when a buffer they
contain is shown.")

(defvar tm:search-face 'tm:search-face
  "Face used to display searched symbols.")

(defvar tm:title-face 'tm:title-face
  "Face used to display titles.")

(defvar tm:step-in-face 'tm:step-in-face
  "Face used to display an entering expression in the stepper.")

(defvar tm:step-out-face 'tm:step-out-face
  "Face used to display an exiting expression in the stepper.")

(defvar tm:breakpoint-face 'tm:breakpoint-face
  "Face used to display breakpoints.")

(defvar tm:error-face 'tm:error-face
  "Face used to display errors.")

(if tm:dark-background-p
  (progn
    (tm:create-face 'tm:search-face "blue" t 'bold)
    (tm:create-face 'tm:title-face "black" "gold" 'bold-italic)
    (tm:create-face 'tm:step-in-face "red" t 'bold)
    (tm:create-face 'tm:step-out-face "blue" t 'bold-italic)
    (tm:create-face 'tm:breakpoint-face () () ())
    (tm:create-face 'tm:error-face ()
		    (if (eq system-type 'windows-nt) "grey" "grey40") 'bold))
  (progn
    (tm:create-face 'tm:search-face "light blue" t 'bold)
    (tm:create-face 'tm:title-face "black" "gold" 'bold-italic)
    (tm:create-face 'tm:step-in-face "pink" t 'bold)
    (tm:create-face 'tm:step-out-face "light blue" t 'bold-italic)
    (tm:create-face 'tm:breakpoint-face () () ())
    (tm:create-face 'tm:error-face ()
		    (if (eq system-type 'windows-nt) "grey" "grey60") 'bold)))

;; Global variables
;; ----------------
;;

(defvar tm:font-lock-keywords
 '(("\\(\\sw\\|\\s_\\)+:" . 1)
   ("^(\\.?def\\(\\sw\\|\\s_\\)+\\s +\\([^ \t\n\)]+\\)" 
    2 font-lock-function-name-face)))

;; Setup
;; -----
;;

(defun tm:talk-mode-variables-specific ()
  (make-local-variable 'blink-paren-function)
  (setq blink-paren-function 'tm:blink-matching-open)
  (make-local-variable 'write-contents-hooks)
  (add-hook 'write-contents-hooks 'tm:run-write-contents-hook)
  (run-hooks 'tm:talk-mode-hooks))

(defvar tm:indent-property 'lisp-indent-function)

;; Font lock mode
;; --------------
;;

(defun tm:font-lock-mode-hook ()
  (if (eq major-mode 'talk-mode)
      (set (make-local-variable 'font-lock-keywords)
           tm:font-lock-keywords)))

(add-hook 'font-lock-mode-hook 'tm:font-lock-mode-hook)


;; Window selection
;; ----------------
;;

(defun tm:select-window (window)
  "Replacement for select-window, which does not work on gnu emacs 19 when
the window is in another frame."
  (let ((screen (window-screen window)))
    (if (not (eq screen (selected-screen)))
	(progn
	  (raise-screen screen)
	  (tm:set-mouse-position window
			      (/ (screen-width screen) 3)
			      (/ (screen-height screen) 3))))
					; Call (unfocus-frame) ?
    (select-window window)))

(cond
  (lucid-emacs-19-12-p
   (defun tm:set-mouse-position (window x y)
     (set-mouse-position window x y)))
  (t
   (defun tm:set-mouse-position (window x y)
     (set-mouse-position (window-screen window) x y))))

(defun tm:display-buffer (buffer herep)
  (cond
   ((tm:deiconify-buffer-window-screen buffer))
   ((save-excursion
      (set-buffer buffer)
      tml:other-screen-p)
    (let ((screen (save-excursion
		    (set-buffer buffer)
		    (tm:create-screen))))
      (sit-for 0)
      (get-buffer-window buffer screen)))
   (tml:other-screen-p
    ;; The current buffer has a dedicated screen. Find a window in another
    ;; not dedicated screen.
    (let* ((screen (tm:get-not-dedicated-screen))
	   (window (screen-selected-window screen)))
      (if herep
	  (progn
	    (set-window-buffer window buffer)
	    window)
	(let ((next-window (next-window window 'no-minibuffer)))
	  (if (not (eq window next-window))
	      (progn
		(set-window-buffer next-window buffer)
		next-window)
	    (let ((new-window (split-window window)))
	      (set-window-buffer new-window buffer)
	      new-window))))))
   (herep
    (let ((window (selected-window)))
      (set-window-buffer window buffer)
      window))
   (t
    (display-buffer buffer))))

(defun tm:get-not-dedicated-screen ()
  "Return a visible screen (preferably the selected one) which is not
dedicated to a buffer. If not found, return the selected screen."
  (let* ((sel-screen (selected-screen))
	 (screen sel-screen)
	 (found-screen ()))
    (while (null found-screen)
      (if (not (tm:screen-dedicated-p screen))
	  (setq found-screen screen)
	(setq screen (tm:next-visible-screen screen))
	(if (eq screen sel-screen)
	    (setq found-screen screen))))
    found-screen))

(cond
  (lucid-emacs-19-11-p
   (defun tm:next-visible-screen (screen)
     (next-screen screen () t)))
  (gnu-emacs-p
   (defun tm:next-visible-screen (screen)
     (next-frame screen ())))
  (t
   (defun tm:next-visible-screen (screen)
     (next-frame screen 'visible))))

(defun tm:screen-dedicated-p (screen)
  "Return T if SCREEN contains any window displaying a buffer with
tml:other-screen-p true."
  (let* ((sel-window (screen-selected-window screen))
	 (window sel-window)
	 (finishedp ())
	 (lockedp ()))
    (while (not finishedp)
      (if (save-excursion
	    (set-buffer (window-buffer window))
	    tml:other-screen-p)
	  (progn
	    (setq lockedp t)
	    (setq finishedp t))
	(setq window (next-window window))
	(if (eq window sel-window)
	    (setq finishedp t))))
    lockedp))

(cond
  (gnu-emacs-p
   (defun tm:deiconify-buffer-window-screen (buffer)
     ;; Gnu Emacs does not have get-buffer-window with the
     ;; FORCE argument
     ()))
  (t
   (defun tm:deiconify-buffer-window-screen (buffer)
     (let ((window (get-buffer-window buffer t t)))
       (and window
	    (progn
	      (deiconify-screen (window-screen window))
	      window))))))

(cond
  ((or gnu-emacs-p lucid-emacs-19-12-p)
   (defun tm:create-screen ()
     (make-frame ())))
  (t
   (defun tm:create-screen ()
     (x-create-screen ()))))

(defun tm:delete-screen ()
  (condition-case ()
      (delete-screen)
    (error ())))

(defun tm:unget-char (char)
  (if gnu-emacs-p
      (setq unread-command-events (list char))
    (setq unread-command-event (character-to-event char))))

(defun tm:get-buffer-window (buffer)
  "Like get-buffer-window, but looks in all the screens."
  (get-buffer-window buffer t))

(defun tm:raise-window-screen (window)
  (if tm:auto-raise-window
      (raise-screen (window-screen window))))

(defun tm:other-window ()
  (other-window 1 t))


;; Text hiliting
;; -------------
;;

(defun tm:insert-title (text)
  "Insert TEXT as a title."
  (let ((start (point)))
    (insert " " text " ")
    (let ((extent (make-extent start (point))))
      (set-extent-face extent tm:title-face))))

;; Menus
;; -----
;;

(tm:add-menus
 ("Edit"
  t
  ("Indent paragraph" tm:indent-paragraph)
  ("Close opening" tm:close-all-opening)
  ("Recenter defun" tm:recenter-defun)
  ("Backward s-exp" backward-sexp)
  ("Forward s-exp" forward-sexp)
  ("Kill s-exp" kill-sexp)
  ("Beginning of defun" tm:beginning-of-defun)
  ("End of defun" tm:end-of-defun)
  ("Switch source/descriptor" tm:switch-desc-source))
 ("Search"
  t
  ("Search definition..." tm:search-symbol-def)
  ("Search references in buffer..." tm:search-symbol-ref-in-buffer)
  ("Search references using grep..." tm:search-symbol-ref)
  ("Next match" tm:search-symbol-continue 
   tm:current-symbol-search)
  ("Previous match" tm:search-symbol-previous 
   tm:current-symbol-search)
  ("Edit *Search*" tm:edit-search-symbol-sites 
   tm:current-symbol-search)
  t
  ("Replace symbol..." tm:replace-symbol)
  ("Replace symbol locally..." tm:replace-symbol-locally)
  ("Q-replace symbol..." tm:query-replace-symbol)
  ("Q-replace symbol locally..." tm:query-replace-symbol-locally)
  t
  ("Find program unit..." ts:find-program-unit
   (fboundp 'ts:find-program-unit))))


;; Events
;; ------
;;

(if lucid-emacs-p
    (progn
      (defun tm:read-event ()
	(next-command-event))
      (defun tm:event-key (event)
	(if (key-press-event-p event)
	    (vector event)
	  ()))
      (defun tm:unread-event (event)
	(setq unread-command-event event))
      (defun tm:key-string (key)
	(char-to-string (event-to-character (aref key 0) t t))))
  (progn
    (defun tm:read-event ()
      (read-event))
    (defun tm:event-key (event)
      (vector event))
    (defun tm:unread-event (event)
      (setq unread-command-events (cons event unread-command-events)))
    (defun tm:key-string (key)
      (char-to-string (aref key 0)))))


(provide 'talk-mode19)
