;;;
;;; Compilation macros.
;;;
;;; ----------------------------------------------------------------------
;;; 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
;;; ----------------------------------------------------------------------
;;;

;;; (tm:in-temporary-help-buffer ...)

(defmacro tm:in-temporary-help-buffer (query-message &rest body)
  "Execute BODY in a temporary help buffer. If QUERY-MESSAGE is not (),
wait the user to type a character and close the buffer."
  (if (null query-message)
      (` (with-output-to-temp-buffer "*Help*"
	   (,@ body)))
    (` (save-window-excursion
	 (with-output-to-temp-buffer "*Help*"
	   (,@ body))
	 (message "%s" (, query-message))
	 (tm:unget-char (read-char))))))

;;; (tm:gensym prefix)

(defvar tm:gensym-counter 0)

(defun tm:gensym (prefix)
  (setq tm:gensym-counter (1+ tm:gensym-counter))
  (make-symbol (concat prefix (int-to-string tm:gensym-counter))))

;;; (tm:add-menus menu*)

(defmacro tm:add-menus (&rest menus)
  (` (if lucid-emacs-p
	 (, (tm:lucid-emacs-menus menus))
       (if (and emacs19p gnu-emacs-p)
	   (, (tm:gnu-emacs-menus menus))
     ) )
) )

;; Known problem: GNU Emacs' current-menubar and lucid-menubar-map (which
;; is computed from current-menubar) are initially empty, although the
;; menubar isn't (see "menu-bar.el"). The two types of menus are not
;; well integrated. As a consequence, we get two "Edit" and two "Search"
;; menus...

(defun tm:lucid-emacs-menus (menus)
  (let* ((pair (tm:menus-code menus))
         (setup (car pair))
         (hook (cdr pair))
         (hook-fn (tm:gensym "hook")))
    (` (progn
         (,@ (if hook
               (` ((defun (, hook-fn) ()
                     (,@ hook))
                   (add-hook 'activate-menubar-hook '(, hook-fn))))))
         (,@ setup)
         (set-menubar-dirty-flag)))))

(defun tm:gnu-emacs-menus (menus)
  (let* ((pair (tm:menus-code menus))
         (setup (car pair))
         (hook (cdr pair))
         (hook-fn (tm:gensym "hook")))
    (` (progn
         (,@ (if hook
               (` ((defun (, hook-fn) ()
                     (,@ hook)
                     (set-menubar-dirty-flag))
                   (add-hook 'activate-menubar-hook '(, hook-fn))))))
         (,@ setup)
         (set-menubar-dirty-flag)))))

(defun tm:menus-code (menus)
  "Return a pair (SETUP . HOOK) where SETUP is a list of forms to evaluate for
the setup of the menus, and HOOK is a list of form to evaluate in the 
activate-menubar-hook."
  (let* ((setup ())
	 (hook ()))
    (while menus
      (let* ((menu (car menus))
	     (pair (tm:menu-code menu))
	     (m-setup (car pair))
	     (m-hook (cdr pair)))
	(setq setup (nconc setup m-setup))
	(setq hook (nconc hook m-hook)))
      (setq menus (cdr menus)))
    (cons setup hook)))

(defun tm:menu-code (menu)
  "Return a pair (SETUP . HOOK) where SETUP is a list of forms to evaluate for
the setup of the menu, and HOOK is a list of form to evaluate in the 
activate-menubar-hook."
  (let* ((menu-name (car menu))
	 (menu-path (list menu-name))
	 (items (cdr menu))
	 (setup ())
	 (hook ()))
    (while items
      (let* ((item (car items))
	     (pair (tm:item-code menu-path item))
	     (i-setup (car pair))
	     (i-hook (cdr pair)))
	(setq setup (nconc setup i-setup))
	(setq hook (nconc hook i-hook)))
      (setq items (cdr items)))
    (cons setup hook)))

(defun tm:item-code (menu-path item)
  "Return a pair (SETUP . HOOK) where SETUP is a list of forms to evaluate for
the setup of the menu, and HOOK a list of forms to evaluate in the 
activate-menubar-hook."
  (if (eq item t)
    (let ((setup-code
	   (` ((let ((menu
		     (car (find-menu-item current-menubar '(, menu-path)))))
		(nconc menu (list "---")))))))
      (cons setup-code ()))
    (let* ((name (car item))
	   (binding (car (cdr item)))
	   (condition (car (cdr (cdr item))))
	   (item-var (tm:gensym "item"))
	   (command (cond
		     ((symbolp binding) binding)
		     ((consp binding) (car (cdr binding)))
		     (t ()))))
      (let* ((setup-code
	      (` ((setq (, item-var)
			(add-menu-item '(, menu-path) (, name)
				       '(, command) t)))))
	     (cond-code
	      (if (null condition)
		()
	        (` ((aset (, item-var) 2 (, condition))))))
             (hook-code
              (cond
               ((symbolp binding)
                cond-code)
               ((stringp binding)
                (` ((let ((cmd (key-binding (, binding))))
                      (if (null cmd)
                        (aset (, item-var) 2 ())
                        (aset (, item-var) 1 cmd)
                        (aset (, item-var) 2 t)
                        (,@ cond-code))))))
               (t
                (let ((str (car binding))
                      (cmd (car (cdr binding))))
                  (` ((let ((cmd (key-binding (, str))))
                        (if (not (eq cmd '(, command)))
			  (aset (, item-var) 2 ())
                          (aset (, item-var) 2 t)
                          (,@ cond-code))))))))))
        (cons setup-code hook-code)))))

(provide 'talk-macros)
