;;;
;;; Major mode for editing talk 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
;;; ----------------------------------------------------------------------
;;;
;;; Name prefixes:
;;;
;;; tm		General prefix for Talk Mode mode identifiers.
;;;


(if (not (boundp 'lisp-mode-syntax-table))
    (load-library "lisp-mode"))

(defvar emacs19p (>= (string-to-int (substring emacs-version 0 2)) 19))
(defvar emacs18p (not emacs19p))

(defvar lucid-emacs-p (or (string-match "Lucid" emacs-version)
			  (string-match "XEmacs" emacs-version)))
(defvar gnu-emacs-p (not lucid-emacs-p))

(defvar lucid-emacs-19-12-p 
        (and lucid-emacs-p
	     (>= (string-to-int (substring emacs-version 3 5)) 12)))
(defvar lucid-emacs-19-11-p
        (and lucid-emacs-p
             (not lucid-emacs-19-12-p)))

(if (and emacs19p gnu-emacs-p)
    (require 'talk-lcompat))

(if emacs19p
    (require 'talk-mode19)
  (require 'talk-mode18))

(if (and emacs19p gnu-emacs-p)
    (require 'talk-lcompat))

(require 'talk-macros)
(require 'talk-groups)
(require 'talk-sites)
(require 'talk-desc)


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

(defvar tm:indent-on-return t
  "When true, \\C-m automatically indents the new line and \\C-j doesn't.
otherwise, \\C-j indents and \\C-m doesn't.")

(defvar tm:clever-indent-p ()
  "When true, typing TAB more than once insert a real indentation,
instead of reindenting the line.")

(defvar tm:search-ref-grep-directories t
  "If this variable has value t, grep is used in the directories of Talk
files currently edited. Otherwise, it is a list of strings
representing directories in which the grep is done.")

(defvar tm:pop-other-window-default (if window-system t ())
  "When (), inhibits the popping of new windows when showing some
buffers.")


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

(defvar tm:sh-file-name "/bin/sh"
  "Path where sh can be found")

(defvar tm:talk-mode-map ()
  "Talk mode keymap.")

(defvar tm:talk-mode-syntax-table ()
  "Talk syntax map")

(defvar tm:talk-source-extension ".t"
  "Extension for source files.")

(defvar tm:talk-desc-extension ".td"
  "Extension for a program unit description files.")

(defvar tm:talk-test-extension ".tt"
  "Extension for a program unit test files.")

(defvar tm:talk-source-file-regexp-format
  (concat ".*/\\(%s\\)" (regexp-quote tm:talk-source-extension) "$")
  "Format to generate a regular expression matching a source file.")

(defvar tm:talk-desc-file-regexp-format
  (concat ".*/\\(%s\\)" (regexp-quote tm:talk-desc-extension) "$")
  "Format to generate a regular expression matching a description file.")

(defvar tm:talk-test-file-regexp-format
  (concat ".*/\\(%s\\)" (regexp-quote tm:talk-test-extension) "$")
  "Format to generate a regular expression matching a test file.")

(defvar tm:talk-source-file-regexp
  (format tm:talk-source-file-regexp-format ".*")
  "Regular expression matching source file names.")

(defvar tm:talk-desc-file-regexp
  (format tm:talk-desc-file-regexp-format ".*")
  "Regular expression matching description file names.")

(defvar tm:talk-test-file-regexp
  (format tm:talk-test-file-regexp-format ".*")
  "Regular expression matching test file names.")

(defvar tm:talk-default-package "user"
  "Default module package.")

(defvar tm:grep-format "grep -l \"%s\" %s/*.t 2> /dev/null"
  "Format used to invoke grep when looking for a symbol's reference.")

(defvar tm:symbol-replacements ()
  "An a-list associating to each symbol its replacement.")

(defvar tm:search-buffer-format "*Search%s*"
  "Default name for buffers displaying search groups.")

(defvar tm:write-contents-hook ()
  "Hooks ran when a buffer in Talk mode is saved.")

(defvar tm:comment-line-regexp "^\\s *;+"
  "Regexp for a comment line.")


;; Buffer-specific variables
;; -------------------------
;;

(defvar tml:other-screen-p ()
  "When true, the current buffer is displayed by tm:display-buffer in
another screen (emacs 19 only)")

(defvar tml:default-buffer-package 'unknown
  "Contains the default package of the current buffer. This variable is
looked for only if the package cannot be found by reading the .td.
See the function tm:buffer-read-package for the possible values of
this variable.")



;; Key maps
;; --------
;;

(global-set-key "\C-C\C-s" 'ts:switch-text-server)

(if tm:talk-mode-map
    ()
  (setq tm:talk-mode-map (copy-keymap lisp-mode-map))
  (define-key tm:talk-mode-map "\C-c\C-l" ()) ; not bound to run-lisp any more
  (define-key tm:talk-mode-map "\C-]" 'tm:close-all-opening)
  (define-key tm:talk-mode-map "\C-c\C-r" 'tm:replace-symbol-locally)
  (define-key tm:talk-mode-map "\C-c\C-v" 'tm:switch-desc-source)
  (define-key tm:talk-mode-map "\C-cr" 'tm:replace-symbol)
  (define-key tm:talk-mode-map "\C-c\C-q\C-r" 'tm:query-replace-symbol-locally)
  (define-key tm:talk-mode-map "\C-c\C-qr" 'tm:query-replace-symbol)
  ;; (define-key tm:talk-mode-map "\C-c\e." 'tm:search-symbol-ref)
  (define-key tm:talk-mode-map "\C-c." 'tm:search-symbol-ref-in-buffer)
  (define-key tm:talk-mode-map "\M-." 'tm:search-symbol-def)
  (define-key tm:talk-mode-map "\M-," 'tm:search-symbol-continue)
  (define-key tm:talk-mode-map "\M-'" 'tm:search-symbol-previous)
  (define-key tm:talk-mode-map "\M-?" 'tm:edit-search-symbol-sites)
  (define-key tm:talk-mode-map "\M-q" 'tm:indent-paragraph)
  (define-key tm:talk-mode-map "\M-\C-l" 'tm:recenter-defun)
  (define-key tm:talk-mode-map "\M-\C-e" 'tm:end-of-defun)
  (define-key tm:talk-mode-map "\M-\C-a" 'tm:beginning-of-defun)
  (define-key tm:talk-mode-map "\t" 'tm:lisp-indent-line)
  (if tm:indent-on-return
      (progn
	(define-key tm:talk-mode-map "\C-m" 'newline-and-indent)
	(define-key tm:talk-mode-map "\C-j" 'newline))))

(defvar tm:newline-syntax ">")
  
(if tm:talk-mode-syntax-table
    ()
  (setq tm:talk-mode-syntax-table (copy-syntax-table lisp-mode-syntax-table))
  (modify-syntax-entry ?' "'" tm:talk-mode-syntax-table)
  (modify-syntax-entry ?. "_" tm:talk-mode-syntax-table)
  (modify-syntax-entry ?[ "_" tm:talk-mode-syntax-table)
  (modify-syntax-entry ?] "_" tm:talk-mode-syntax-table)
  (modify-syntax-entry ?: "_" tm:talk-mode-syntax-table)
  (modify-syntax-entry ?\\ "\\" tm:talk-mode-syntax-table)
;; Useless until Emacs properly manage parse-sexp-ignore-comments = t
; (modify-syntax-entry ?# "_ 14" tm:talk-mode-syntax-table)
; (modify-syntax-entry ?| "_ 23" tm:talk-mode-syntax-table)
  (modify-syntax-entry ?| "\"" tm:talk-mode-syntax-table)
  (modify-syntax-entry ?\n ">" tm:talk-mode-syntax-table)
  (modify-syntax-entry ?\f tm:newline-syntax tm:talk-mode-syntax-table)
  (modify-syntax-entry ?\; "<" tm:talk-mode-syntax-table))


;; To enter in Talk mode
;; ---------------------
;;

(defun talk-mode ()
  "\
Major mode for editing Talk code.
Delete converts tabs to spaces as it moves back.
Blank lines separate paragraphs. Semicolons start comments.
\\{tm:talk-mode-map}

Entry to this mode calls the value of talk-mode-hook
if that value is non-nil."
  (interactive)
  (use-local-map tm:talk-mode-map)
  (setq major-mode 'talk-mode)
  (setq mode-name "Talk")
  (tm:talk-mode-variables)
  (set-syntax-table tm:talk-mode-syntax-table)
  (td:insert-new-file-template)
  (run-hooks 'talk-mode-hook))

(defun tm:talk-mode-variables ()
  "Set up talk local variables."
  (make-local-variable 'blink-matching-paren-distance)
  (setq blink-matching-paren-distance 12000)
  (lisp-mode-variables t)
  (make-local-variable 'parse-sexp-ignore-comments)
  (setq parse-sexp-ignore-comments ())	; Buggy emacs! beginning-of-defun
					; will not work properly with this
					; variable set to t.
  (tm:talk-mode-variables-specific))


;; Show match
;; ----------
;;

(defun tm:blink-matching-open ()
  "Move cursor momentarily to the beginning of the sexp before point.
Enhanced version of blink-matching-open."
  (and (> (point) (1+ (point-min)))
       (/= (char-syntax (char-after (- (point) 2))) ?\\ )
       blink-matching-paren
       (let* ((oldpos (point))
	      (blinkpos)
	      (blinkcol)
	      (mismatch))
	 (save-excursion
	   (save-restriction
	     (if blink-matching-paren-distance
		 (narrow-to-region
		  (max (point-min)
		       (- (point) blink-matching-paren-distance))
		  oldpos))
	     (condition-case ()
		 (progn
		   (setq blinkpos (scan-sexps oldpos -1))
		   (goto-char blinkpos)
		   (setq blinkcol blinkpos))
	       (error nil)))
	   (and blinkpos (/= (char-syntax (char-after blinkpos)) ?\$)
		(setq mismatch
		      (/= (char-after (1- oldpos))
			  (tm:syntax-entry-paren
			    (aref (syntax-table) (char-after blinkpos))))))
	   (if mismatch (setq blinkpos nil))
	   (if blinkpos
	       (progn
		 (goto-char blinkpos)
		 (if (pos-visible-in-window-p)
		     (sit-for 1)
		   (let ((left (buffer-substring
				(progn (beginning-of-line) (point))
				blinkpos))
			 (right (buffer-substring
				blinkpos
				(progn (end-of-line) (point)))))
		     (message "Matches %s\\%s" left right))))
	     (cond (mismatch
		    (message "Mismatched parentheses"))
		   ((not blink-matching-paren-distance)
		    (message "Unmatched parenthesis"))))))))

(defun tm:close-all-opening (&optional dont-blink-p)
  "Close all the opening parentheses until the current toplevel form is
complete.
Return the number of inserted parentheses."
  (interactive)
  (let ((matching ())
	(count 0)
	(bod (save-excursion (tm:beginning-of-defun) (point)))
	(eod (save-excursion (tm:end-of-defun) (point))))
    (save-restriction
      (narrow-to-region bod eod)
      (while (and
	      (let ((incompletep ()))
		(save-excursion
		  (goto-char bod)
		  (condition-case ()
		      (forward-sexp 1)
		    (error (setq incompletep t))))
		incompletep)
	      (progn
		(setq matching ())
		(condition-case ()
		    (save-excursion
		      (backward-up-list 1)
		      (setq matching
			    (tm:syntax-entry-paren
			      (aref (syntax-table) (char-after (point))))))
		  (error nil))
		matching))
	(setq count (+ count 1))
	(insert-char matching 1)))
    (if (not (or (= count 0) dont-blink-p))
	(tm:blink-matching-open))
    count))

(if (and emacs19p gnu-emacs-p)
  ;; The internal representation of syntax table entries has changed in
  ;; GNU Emacs 19.
  (defun tm:syntax-entry-paren (syntax-entry)
    (logand (if (consp syntax-entry) (cdr syntax-entry) (lsh syntax-entry -8))
            255
  ) )
  (defun tm:syntax-entry-paren (syntax-entry)
    (logand (lsh syntax-entry -8)
            255
  ) )
)


;; Replacement of a symbol
;; -----------------------
;;

(defvar tm:sexp-delimiter-regexp "\\(\\s(\\|\\s\"\\|\\s$\\|\\s<\\|\\s.\\|\\s)\\|\\s\\\\|\\s'\\|\\s>\\|\\s \\|#.\\)"
  "Regular expression matching a s-expression delimiter")

(defun tm:replace-symbol-locally ()
  "Replace a symbol in the enclosing toplevel form. Useful to change the
name of a local variable."
  (interactive)
  (save-excursion
    (tm:do-replace-symbol () ())))

(defun tm:query-replace-symbol-locally ()
  "Query replace the current symbol in the enclosing toplevel form. Useful
to change the name of a local function or variable."
  (interactive)
  (tm:do-replace-symbol () t))

(defun tm:replace-symbol ()
  "Replace a symbol everywhere in the buffer. Useful to change the name of
a global function or variable."
  (interactive)
  (save-excursion
   (tm:do-replace-symbol t ())))

(defun tm:query-replace-symbol ()
  "Query a symbol everywhere in the buffer. Useful to change the name of a
global function or variable."
  (interactive)
  (tm:do-replace-symbol t t))

(defun tm:do-replace-symbol (globalp queryp)
  "Replace a symbol in the whole buffer if GLOBALP is true, and in
the enclosing toplevel form otherwise. If QUERYP is true, make
a query replace."
  (let* ((message-prefix
	  (cond
	   ((and globalp queryp) "Query replace: ")
	   ((and globalp (not queryp)) "Replace: ")
	   ((and (not globalp) queryp) "Query replace locally: ")
	   ((and (not globalp) (not queryp)) "Replace locally: ")))
	 (from (tm:get-symbol message-prefix)))
    (if from
	(let* ((pair (assoc from tm:symbol-replacements))
	       (default (if pair (cdr pair) from))
	       (to (read-from-minibuffer (concat message-prefix from " with: ")
					 default))
	       (begin ())
	       (end ()))
	  (if (not (string= to ""))
	      (progn
		(if pair
		    (rplacd pair to)
		  (setq tm:symbol-replacements
			(cons (cons from to) tm:symbol-replacements)))
		(if globalp
		    (progn
		      (setq begin (point-min))
		      (setq end (point-max)))
		  (let ((here (point)))
		    (save-excursion
		      (tm:beginning-of-defun)
		      (setq begin (point))
		      (goto-char here)
		      (tm:end-of-defun)
		      (setq end (point)))))
		(tm:replace-sexp-in-region from to begin end queryp)))))))

(defconst tm:query-replace-help
  "Type space or `y' to replace one match, delete or `n' to skip to next,
esc or `q' to exit
C-l to clear the screen, redisplay, and offer same replacement again,
! to replace all remaining matches with no more questions"
  "Help message while in s-expression query-replace")

(defun tm:replace-sexp-in-region (from-string to-string begin end queryp)
  "Replace FROM-STRING with TO-STRING in the region delimited by BEGIN
and END. Query each replacement if QUERYP is true."
  (let* ((case-fold-search ())
	 (from-regexp (concat tm:sexp-delimiter-regexp
			      "\\("
			      (regexp-quote from-string)
			      "\\)"
			      tm:sexp-delimiter-regexp))
	 (to-regexp (concat "\\1" to-string "\\3"))
	 (to-length (length to-string))
	 (char ())
	 (continuep ())
	 (current-queryp queryp)
	 (message-string "Query replacing s-expression %s with %s: ")
	 (end-mark (make-marker)))
    (set-marker end-mark end)
    (catch 'finished
      (goto-char begin)
      (while (and (<= (point) end-mark)
		  (re-search-forward from-regexp end-mark t))
	(if (not current-queryp)
	    (replace-match to-regexp t nil)
	    (goto-char (match-beginning 3))
	    (setq continuep ())
	    (while (not continuep)
	      (setq continuep t)
	      (message message-string from-string to-string)
	      (setq char (read-char))
	      (cond
		((= char ??)
		 (tm:in-temporary-help-buffer
		  (format message-string from-string to-string)
		  (princ "Query replacing s-expression ")
		  (princ from-string)
		  (princ " with ")
		  (princ to-string)
		  (princ ".\n\n")
		  (princ tm:query-replace-help))
		 (setq continuep ()))
		((or (= char ?\e) (= char ?q))
		 (throw 'finished ()))
		((or (= char ?\ ) (= char ?y))
		 (replace-match to-regexp t nil))
		((= char ?!)
		 (replace-match to-regexp t nil)
		 (setq current-queryp ()))
		((or (= char ?\177) (= char ?n)))
		((= char ?\C-l)
		 (recenter nil)
		 (setq continuep ()))
		(t 
		 (tm:unget-char char)
		 (throw 'finished ())))))
	(goto-char (match-beginning 2))
	(forward-char to-length))))
    (if queryp (message "Finished.")))


;; General search mechanism
;; ------------------------
;;
;; A search is a site group of simple site items.
;;

(tm:defstruct tm:search tm:site-group
   (description
    ;; Description of the search, a string.
    places
    ;; List of search places. A search place is
    ;; - A list (message <string>), where the message is to be displayed
    ;; when this element is reached.
    ;; - A list (function-name arg...) where the function is to be called
    ;; with the given arguments to return a search place or a
    ;; list of search places to be appended in front of tm:search-places.
    (seen-buffers default: ())
    ;; List of buffers already proceeded.
    (succeededp default: ())
    ;; T if the search has succeeded.
   )
   (method: tm:group-print-header))

(defun tm:search-clear (search places description)
  (tm:set-search-description search description)
  (tm:set-search-places search places)
  (tm:set-search-seen-buffers search ())
  (tm:set-search-succeededp search ())
  (tm:group-clear search))

(defun tm:search-next (search)
  "Go to the next search point."
  (let ((tm:*group-buffer-caller* 'interactive))
    (let ((againp t))
      (while againp
	(setq againp ())
	(cond
	 ((tm:group-next-selectable-item search)
	  (tm:set-search-succeededp search t))
	 (t
	  (let ((places (tm:search-places search)))
	    (if (null places)
		(let ((description (tm:search-description search)))
		  (if (tm:search-succeededp search)
		      (error "No more %s." description)
		    (error "No %s found." description)))
	      (let ((place (car places)))
		(tm:set-search-places search (cdr places))
		(if (eq (car place) 'message)
		    (message "%s" (car (cdr place)))
		  (setq againp t)
		  (let ((fn (car place))
			(args (cdr place)))
		    (if (fboundp fn)
			(apply fn search args)))))))))))))

(defun tm:search-previous (search)
  "Go to the previous search point."
  (let ((tm:*group-buffer-caller* 'interactive))
    (if (not (tm:group-previous-selectable-item search))
	(let ((description (tm:search-description search)))
	  (error "No previous %s" description)))))

(defun tm:push-search-place (search place)
  "Add to SEARCH the search place PLACE."
  (tm:set-search-places search (cons place (tm:search-places search))))

(defun tm:complete-search (search)
  "Resolve all search places of SEARCH."
  (let ((places ()))
    (while (setq places (tm:search-places search))
      (let ((place (car places)))
	(tm:set-search-places search (cdr places))
	(if (not (eq (car place) 'message))
	    (let ((fn (car place))
		  (args (cdr place)))
	      (if (fboundp fn)
		  (apply fn search args))))))))

(tm:defmethod tm:group-print-header ((search tm:search))
  (let ((desc (tm:search-description search)))
    (tm:insert-centered-title desc)
    (newline)
    (newline)))


;; Common basic search functions
;; -----------------------------
;;

(defvar tm:buffer-search-message "Scanning buffer %s (%d%%), %d matches."
  "Message displayed during the search in a buffer.")

(defun tm:search-regexp-in-buffer (search regexp match-beg match-end buffer
					  &optional visitp)
  "Update SEARCH with the matches of REGEXP in BUFFER. The created extent
cover the region delimited by (apply (car match-beg) (cdr match-beg)) and
(apply (car match-end) (cdr match-end)). If no match is found but VISITP 
is true, an empty site item is created anyway. Return () if no match was
found, otherwise the number of matches."
  (let* ((case-fold-search ())
         (bufname (buffer-name buffer))
	 (matches 0))
    (message tm:buffer-search-message bufname 0 0)
    (tm:set-search-seen-buffers
     search
     (cons buffer (tm:search-seen-buffers search)))
    (save-excursion
      (set-buffer buffer)
      (goto-char (point-min))
      (while (re-search-forward regexp () t)
    	(message tm:buffer-search-message
		 bufname (tm:relative-position) matches)
	(setq matches (1+ matches))
	(forward-char -1)
	(let ((site (tm:make-search-site bufname: bufname))
	      (item (tm:make-site-item)))
	  (tm:site-add-extent site (apply (car match-beg) (cdr match-beg))
                                   (apply (car match-end) (cdr match-end)))
	  (tm:site-group-add-item search item site () ())))
      (message tm:buffer-search-message bufname 100 matches)
      (cond
       ((> matches 0) matches)
       ((not visitp) ())
       (t
	(let ((site (tm:make-search-site bufname: bufname))
	      (item (tm:make-site-item)))
	  (tm:site-group-add-item search item site () ())
	  matches))))))

(defun tm:search-in-other-buffers (search package pname search-fn)
  "Map SEARCH-FN over all the Talk source buffers not yet seen in
SEARCH. The function is called with SEARCH, PACKAGE, PNAME and the
buffer. Used to implement tm:search-def-in-other-buffers and friends."
  (let ((buffers (buffer-list))
	(seen-buffers (tm:search-seen-buffers search)))
    (while buffers
      (let ((buffer (car buffers)))
	(if (and (not (memq buffer seen-buffers))
		 (tm:source-buffer-p buffer))
	    (funcall search-fn search package pname buffer)))
      (setq buffers (cdr buffers)))))
      

;; Symbol search common functions
;; ------------------------------
;;

(tm:defstruct tm:symbol-search tm:search
  ()
  (method: tm:group-delete-hook))

(defvar tm:current-symbol-search ()
  "Current symbol search, or () if there is no current search.")

(tm:defmethod tm:group-delete-hook ((group tm:symbol-search))
  "Function called when the symbol search group is killed."
  (setq tm:current-symbol-search ())
  t)

(defun tm:make-new-symbol-search (places description)
  "Create a new symbol search or clear the current one if any."
  (if tm:current-symbol-search
      (tm:search-clear tm:current-symbol-search places description)
    (setq tm:current-symbol-search
	  (tm:make-symbol-search places: places description: description))))

(defun tm:search-symbol-continue ()
  "Search for the next site of the symbol."
  (interactive)
  (if (null tm:current-symbol-search)
      (error "No search in progress")
    (tm:search-next tm:current-symbol-search)))

(defun tm:search-symbol-previous ()
  "Go to the previous definition of the symbol."
  (interactive)
  (if (null tm:current-symbol-search)
      (error "No search in progress")
    (tm:search-previous tm:current-symbol-search)))

(defun tm:edit-search-symbol-sites ()
  "Edit the current definition search sites in a buffer."
  (interactive)
  (if (null tm:current-symbol-search)
      (error "No search in progress")
    (tm:complete-search tm:current-symbol-search)
    (tm:group-show-buffer-attach tm:current-symbol-search
				 tm:search-buffer-format () t)))


;; Definition search
;; -----------------
;;

(defvar tm:definition-prefix-regexp "\\(^(\\.?def\\(\\sw\\|\\s_\\)*\\s +\\)"
  "Prefix of a definition.")

(defun tm:search-symbol-def ()
  "Search for the definition of a symbol, by default the currently pointed
symbol. A definition for a symbol is merely a toplevel expression beginning
with (def... followed by this symbol.
This function first look in the current buffer; then, if there is a running
Talk process, queries the databases to find modules exporting the symbol."
  (interactive)
  (let* ((exploded (tm:get-exploded-symbol "Find definition of: ")))
    (if exploded
	(let* ((package (car exploded))
	       (pname (cdr exploded))
	       (places (list (list 'tm:search-def-in-buffer
				   package
				   pname
				   (current-buffer))
			     (list 'ts:search-exported-defs
				   package
				   pname)))
	       (description (format "definitions of %s"
				    (tm:make-symbol package pname))))
	  (tm:make-new-symbol-search places description)
	  (tm:search-next tm:current-symbol-search)))))

(defun tm:get-exploded-symbol (message)
  "Query for a symbol and return it as a pair (package . pname). Use
MESSAGE as a query message. Return () if the symbol is empty."
  (let* ((symbol (tm:symbol-at-point-string ()))
	 (buffer (current-buffer))
	 (full-symbol ()))
    (if symbol
	(let* ((exploded (tm:explode-symbol symbol buffer))
	       (package (car exploded))
	       (pname (cdr exploded)))
	  (setq full-symbol (tm:make-symbol package pname))
	  (if (eq package 'unknown)
	      (setq message (concat message "<unknown package> ")))))
    (setq full-symbol
	  (read-from-minibuffer message full-symbol))
    (if (string= full-symbol "")
	()
      (tm:explode-symbol full-symbol buffer))))

(defun tm:get-symbol (message &optional confirmp)
  "Get the currently pointed symbol, querying it with MESSAGE if there
is no current symbol. If optional CONFIRMP is true, always ask for
confirmation."
  (let ((current-symbol (tm:symbol-at-point-string ())))
    (if (and (not confirmp) current-symbol)
	current-symbol
      (let* ((symbol (read-from-minibuffer message current-symbol)))
	(if (string= symbol "")
	    ()
	  symbol)))))

(defun tm:search-def-in-buffer (search package pname buffer &optional visitp)
  "Update the SEARCH with the definitions of symbol with PACKAGE and
PNAME in BUFFER. If no definition if found but optional VISITP is true, a
dummy extent is created anyway."
  (let* ((regexp (tm:definition-regexp package pname buffer)))
    (tm:search-regexp-in-buffer search regexp '(match-end 1) '(point)
				buffer visitp)))

; Currently not used
(defun tm:search-def-in-other-buffers (search package pname)
  "Update the SEARCH with the definitions of symbol with PACKAGE and PNAME
in the Talk source buffers not yet seen in the search."
  (tm:search-in-other-buffers search package pname
			      'tm:search-def-in-buffer))

(defun tm:definition-regexp (package pname read-package-buffer)
  "Return a regular expression which matches with the definition of SYMBOL."
  (concat tm:definition-prefix-regexp
	  (tm:symbol-regexp package pname read-package-buffer)
	  tm:sexp-delimiter-regexp))

(defun tm:symbol-regexp (package pname read-package-buffer)
  "Return a regular expression matching the symbol with PACKAGE and PNAME.
READ-PACKAGE-BUFFER is the buffer whose read package must be used if needed."
  (cond
   ((null package)
    (regexp-quote pname))
   ((eq package 'unknown)
    (concat "\\(\\_\\|\\w\\)*\\." (regexp-quote pname)))
   (t (let ((read-package (tm:buffer-read-package read-package-buffer)))
	(if (or (eq read-package 'unknown)
		(string= read-package package))
	    (concat "\\("
		    (regexp-quote (concat "." pname))
		    "\\|"
		    (regexp-quote (concat package "." pname))
		    "\\)")
	  (regexp-quote (concat package "." pname)))))))


;; References search
;; -----------------
;;

(defun tm:search-symbol-ref ()
  "Search for the references to a symbol, by default the currently pointed
symbol.
If the variable tm:search-ref-grep-directories contains T, this function
uses grep in all the directories of edited Talk files. Otherwise,
this variable must contain a list of directories (strings) in which
the search is done."
  (interactive)
  (let* ((exploded (tm:get-exploded-symbol "Find references to: ")))
    (if exploded
	(let* ((package (car exploded))
	       (pname (cdr exploded))
	       (places (list (list 'tm:search-ref-using-grep
				   package
				   pname)))
	       (description (format "references to %s"
				    (tm:make-symbol package pname))))
	  (tm:make-new-symbol-search places description)
	  (tm:search-next tm:current-symbol-search)
	  (tm:complete-search tm:current-symbol-search)))))

(defun tm:search-symbol-ref-in-buffer ()
  "Search for the references to a symbol, by default the currently pointed
symbol, in the current buffer."
  (interactive)
  (let* ((exploded (tm:get-exploded-symbol "Find buffer references to: ")))
    (if exploded
	(let* ((package (car exploded))
	       (pname (cdr exploded))
	       (places (list (list 'tm:search-ref-in-buffer
				   package
				   pname
				   (current-buffer))))
	       (description (format "references to %s in %s"
				    (tm:make-symbol package pname)
				    (buffer-name (current-buffer)))))
	  (tm:make-new-symbol-search places description)
	  (tm:search-next tm:current-symbol-search)))))

(defun tm:search-ref-in-buffer (search package pname buffer)
  "Update the SEARCH with the references to the symbol with PACKAGE and
PNAME in BUFFER. Return T if a reference was found, () otherwise."
  (let* ((regexp (tm:reference-regexp package pname buffer)))
    (tm:search-regexp-in-buffer search regexp '(match-end 1) '(point)
				buffer)))

; Currently not used
(defun tm:search-ref-in-other-buffers (search package pname)
  "Update the SEARCH with the references of symbol with PACKAGE and PNAME
in the Talk source buffers not yet seen."
  (tm:search-in-other-buffers search package pname 'tm:search-ref-in-buffer))

(defun tm:search-ref-using-grep (search package pname)
  "Update the SEARCH with the references of symbol with PACKAGE and PNAME,
using GREP to scan the directories specified by the variable
tm:search-ref-grep-directories."
  (let ((directories (if (listp tm:search-ref-grep-directories)
			 tm:search-ref-grep-directories
		       (tm:prunit-buffers-directories))))
    (while directories
      (let ((directory (car directories)))
	(tm:push-search-place
	 search
	 (list 'tm:search-ref-in-directory package pname directory)))
      (setq directories (cdr directories)))))

(defun tm:prunit-buffers-directories ()
  "Return the list of the directories of Talk files currently edited."
  (let ((buffers (buffer-list))
	(directories ())
	(inodes ()))
    (while buffers
      (let ((buffer (car buffers)))
	(if (tm:prunit-buffer-p buffer)
	    (let ((file (buffer-file-name buffer)))
	      (if file
		  (let* ((dir-with-slash (file-name-directory file))
			 (directory (substring dir-with-slash 0
					       (1- (length dir-with-slash))))
			 (inode (tm:real-file-inode directory)))
		    (if (not (memq inode inodes))
			(progn
			  (setq inodes (cons inode inodes))
			  (setq directories (cons directory directories))))))))
	(setq buffers (cdr buffers))))
    directories))

(defvar tm:grepped-files ()
  "List of files in which grep found references to the currently 
searched symbol.")

(defvar tm:grep-message "Scanning directory %s, found %s files...%s"
  "Message displayed during the grep.")

(defvar tm:grep-directory ()
  "Directory in which the current grep is being done")

(defun tm:search-ref-in-directory (search package pname directory)
  "Update SEARCH so that all the files in DIRECTORY which apparently
contain references to a symbol with PACKAGE and PNAME are scanned."
  (message tm:grep-message directory 0 "")
  (setq tm:grepped-files ())
  (setq tm:grep-directory directory)
  (let* ((regexp (tm:reference-grep-regexp package pname))
	 (command (format tm:grep-format regexp directory))
	 (process (start-process "grep" () tm:sh-file-name "-c"
				 (concat "exec " command))))
    (set-process-filter process 'tm:grep-search-filter)
    (unwind-protect
	(while (not (tm:process-dead-p process))
	  (accept-process-output process))
      (if (not (tm:process-dead-p process))
	  (tm:quit-process process)))
    (let ((files tm:grepped-files))
      (message tm:grep-message directory (length files) "done.")
      (while files
	(tm:push-search-place
	 search
	 (list 'tm:search-ref-in-file package pname (car files)))
	(setq files (cdr files))))))

(defun tm:grep-search-filter (process line)
  "Filter for grep while looking for references."
  (let ((index 0))
    (while (string-match "^\\([^\n\r\j]+\\)[\n\r\j]" line index)
      (let ((file (substring line 0 (match-end 1))))
        (setq index (match-end 0))
	(setq tm:grepped-files (cons file tm:grepped-files))
	(message tm:grep-message
		 tm:grep-directory
		 (length tm:grepped-files)
		 "")))))

(defun tm:search-ref-in-file (search package pname file)
  "Update SEARCH with the references to the symbol with PACKAGE and PNAME
in FILE."
  (if (file-readable-p file)
      (progn
	(message "Opening file %s..." file)
	(let ((buffer (tm:find-file-noselect file)))
	  (message "Opening file %s..." file)
	  (if (not (memq buffer (tm:search-seen-buffers search)))
	      (if (null (tm:search-ref-in-buffer search package pname buffer))
		  (kill-buffer buffer)))))))
  
(defun tm:reference-regexp (package pname read-package-buffer)
  "Return a regular expression which matches with a reference to SYMBOL."
  (concat tm:sexp-delimiter-regexp
	  (tm:symbol-regexp package pname read-package-buffer)
	  tm:sexp-delimiter-regexp))

(defun tm:reference-grep-regexp (package pname)
  "Return an grep regular expression which matches a reference to
SYMBOL."
  (let* ((string (if package (concat "." pname) pname)))
    (regexp-quote string)))

;; Indentation
;; -----------
;;
;; This function is just copied from lisp-mode.el; the only change is
;; that defining form names can now begin with a dot.
;;

(defun tm:lisp-indent-function (indent-point state)
  (let ((tm:last-sexp (if (boundp 'last-sexp) 
			  last-sexp 
			;; For GNU Emacs 19.29
			calculate-lisp-indent-last-sexp)))
    (let ((normal-indent (current-column)))
      (goto-char (1+ (elt state 1)))
      (parse-partial-sexp (point) tm:last-sexp 0 t)
      (if (and (elt state 2)
	       (not (looking-at "\\sw\\|\\s_")))
	  ;; car of form doesn't seem to be a a symbol
	  (progn
	    (if (not (> (save-excursion (forward-line 1) (point))
			tm:last-sexp))
		(progn (goto-char tm:last-sexp)
		       (beginning-of-line)
		       (parse-partial-sexp (point) tm:last-sexp 0 t)))
	    ;; Indent under the list or under the first sexp on the
	    ;; same line as tm:last-sexp.  Note that first thing on that
	    ;; line has to be complete sexp since we are inside the
	    ;; innermost containing sexp.
	    (backward-prefix-chars)
	    (current-column))
	(let ((function (buffer-substring (point)
					  (progn (forward-sexp 1) (point))))
	      method)
	  (setq method (get (intern-soft function) tm:indent-property))
	  (cond ((or (eq method 'defun)
		     (and (null method)
			  (> (length function) 3)
			  (string-match "\\`\\.?def" function)));; Here !!!
		 (lisp-indent-defform state indent-point))
		((integerp method)
		 (lisp-indent-specform method state
				       indent-point normal-indent))
		(method
		 (funcall method state indent-point))))))))

(fset tm:indent-property (symbol-function 'tm:lisp-indent-function))

(defun tm:lisp-indent-line (&optional whole-exp)
  "If we are on a comment line or if this command is repeated, insert a tab.
Otherwise, Indent current line as Lisp code.
With argument, indent any additional lines of the same expression
rigidly along with this one."
  (interactive "P")
  (if (and tm:clever-indent-p
	   (eq last-command 'tm:lisp-indent-line))
      (tab-to-tab-stop)
    (lisp-indent-line whole-exp)))
  

;; Paragraph indentation
;; ---------------------
;;

(defun tm:indent-paragraph ()
  "If in a comment, indent the comment paragraph bounded by
non-comments, blank lines or empty comment lines.  Otherwise indent the
containing defun."
  (interactive)
  (save-excursion
    (let ((comment-region (tm:get-comment-region t)))
      (if comment-region
	  (let ((fill-prefix (concat (car comment-region) " "))
		(begin (car (cdr comment-region)))
		(end (car (cdr (cdr comment-region)))))
	    (fill-region-as-paragraph begin end))
	(let ((here (point)))
	  (tm:end-of-defun)
	  (or (condition-case ()
		  (save-excursion
		    (forward-sexp -1)
		    (if (and (bolp) (<= (point) here))
			(progn (indent-sexp) t)))
		(error ()))
	      (let* ((closing (tm:close-all-opening t))
		     (end (point-marker)))
		(unwind-protect
		    (progn
		      (goto-char here)
		      (tm:beginning-of-defun)
		      (beginning-of-line)
		      (save-restriction
			(narrow-to-region (point) end)
			(condition-case ()
			    (indent-sexp)
			  (error ()))))
		  (goto-char end)
		  (delete-backward-char closing)))))))))


;; Miscellaneous
;; -------------
;;

(defun tm:switch-desc-source ()
  "If currently editing a source or test file, switch to its corresponding
description file, re-reading it if it has changed on disk . If currently
editing a description file, switch to its corresponding source file."
  (interactive)
  (let ((file (buffer-file-name (current-buffer))))
    (cond
      ((null file)
       (error "not in a file buffer"))
      ((tm:source-file-p file)
       (find-file (tm:source-file-desc-file file)))
      ((tm:test-file-p file)
       (let ((desc-file (tm:test-file-desc-file file)))
	 (if (null desc-file)
	     (error "descriptor not found for test file %s" file)
	   (find-file desc-file))))
      ((tm:desc-file-p file)
       (find-file (tm:desc-file-source-file file)))
      (t (error "not in a source or descriptor buffer")))))

(defun tm:run-write-contents-hook ()
  (run-hooks 'tm:write-contents-hook)
  ())

(defun tm:recenter-defun ()
  "Recenter the current definition in the window."
  (interactive)
  (let* ((window (selected-window))
	 (start (save-excursion
		  (tm:beginning-of-defun)
		  (beginning-of-line)
		  (point)))
	 (end (save-excursion
		(tm:end-of-defun)
		(beginning-of-line)
		(point)))
	 (length (count-lines start end))
	 (height (- (window-height window) 1)))
    (if (< length height)
	(let* ((margin (/ (- height length) 2))
	       (new (save-excursion
		      (goto-char start)
		      (forward-line (- margin))
		      (point))))
	  (set-window-start window new))
      (set-window-start window start)
      (if (not (pos-visible-in-window-p))
	  (let ((new (save-excursion
		   (beginning-of-line)
		   (forward-line (- (- height 1)))
		   (point))))
	    (set-window-start window new))))))
    
  

;; Reading a description file
;; --------------------------
;;

(defvar tm:buffer-packages ()
  "An a-list containing pairs of the form (PRUNIT MTIME . PACKAGE), where
MTIME is the modification time of the descriptor file when the package was
read the last time.")

(defun tm:buffer-read-package (buffer)
  "Return the package associated with BUFFER as a string. If BUFFER is
not a program unit buffer, or if it has no associated description file,
return UNKNOWN.
This function is quite complicated, but we have to make it quite efficient:
If the description file is in a buffer, read the package in this buffer;
if the description file is newer, ask the user if he wants to revert the
buffer.
Otherwise, check the description file date with tm:buffer-packages; if
the description file is newer, load it in a temporary buffer and read
the package; otherwise, return the package stored in tm:buffer-packages."
  (let (file prunit desc-file desc-buffer)
    (cond
      ((null (setq file (buffer-file-name buffer)))
       tml:default-buffer-package)
      ((null (setq prunit (tm:file-program-unit file)))
       tml:default-buffer-package)
      ((null (setq desc-file (tm:file-desc-file file)))
       tml:default-buffer-package)
      ((setq desc-buffer (tm:get-file-buffer desc-file))
       (if (and (buffer-modified-p desc-buffer)
		(not (verify-visited-file-modtime desc-buffer))
		(y-or-n-p (format "%s has changed; read new contents? "
				  (file-name-nondirectory desc-file))))
	   (save-excursion
	     (set-buffer desc-buffer)
	     (revert-buffer t t)))
       (tm:desc-buffer-read-package desc-buffer))
      ((not (file-readable-p desc-file))
       tml:default-buffer-package)
      (t
       (let ((mtime (tm:real-file-mtime desc-file))
	     (pair (assoc prunit tm:buffer-packages)))
	 (if (null pair)
	     (let* ((desc-buffer (tm:find-file-noselect desc-file))
		    (package (tm:desc-buffer-read-package desc-buffer)))
	       (kill-buffer desc-buffer)
	       (setq tm:buffer-packages
		 (cons (cons prunit (cons mtime package))
		       tm:buffer-packages))
	       package)
	   (let ((last-mtime (car (cdr pair))))
	     (if (equal mtime last-mtime)
		 (cdr (cdr pair))
	       (let* ((desc-buffer
		       (tm:find-file-noselect desc-file))
		      (package
		       (tm:desc-buffer-read-package desc-buffer)))
		 (kill-buffer desc-buffer)
		 (rplaca (cdr pair) mtime)
		 (rplacd (cdr pair) package)
		 package)))))))))

(defun tm:desc-buffer-read-package (desc-buffer)
  "Return the package in the current buffer."
  (save-excursion
    (set-buffer desc-buffer)
    (let* ((pack (tm:read-key "package:")))
      (if (null pack)
	  tm:talk-default-package
	(symbol-name pack)))))

(defun tm:goto-key (key)
  "Goto the key KEY in the current buffer. If found, return T, otherwise
return ()."
  (goto-char (point-min))
  (let ((regexp (concat "^" (regexp-quote key) tm:sexp-delimiter-regexp)))
    (re-search-forward regexp () t)))

(defun tm:read-key (key)
  "Return the value of the key KEY in the current buffer, or () if not
found."
  (save-excursion
    (if (tm:goto-key key)
	(tm:talk-read)
      ())))

(defun tm:talk-read ()
  "Read next expression in the current buffer using the Talk syntax table."
  (let ((syntax-table (syntax-table)))
    (set-syntax-table tm:talk-mode-syntax-table)
    (unwind-protect (read (current-buffer))
      (set-syntax-table syntax-table))))


;; Utilities
;; ---------
;;

(defun tm:relative-position ()
  "Return the relative position % in the current buffer. Thanks to the
func-menu 3.1 package from Ake Stenhoff."
  (let ((pos (point))
	(total (buffer-size)))
    (if (> total 50000)
	;; Avoid overflow from multiplying by 100!
	(/ (1- pos) (max (/ total 100) 1))
      (/ (* 100 (1- pos)) (max total 1)))))

(defun tm:quit-process (process)
  (quit-process process))

(defun tm:current-line ()
  "Return the current line number, starting from 1."
  (save-restriction
    (widen)
    (save-excursion
      (beginning-of-line)
      (1+ (count-lines (point-min) (point))))))

(defun tm:current-line-character ()
  "Return the number of the character on the line, starting from 0. "
  (- (point) (save-excursion (beginning-of-line) (point))))

(defun tm:save-some-buffers (buffers)
  "Propose to save the modified BUFFERS. Return T if all the modified buffers
has been saved, and () otherwise."
  (let ((all-saved t))
    (while buffers
      (let ((buffer (car buffers)))
	(if (buffer-modified-p buffer)
	    (if (y-or-n-p (format "Save file %s " (buffer-file-name buffer)))
		(save-excursion
		  (set-buffer buffer)
		  (save-buffer))
	      (setq all-saved ())))
	(setq buffers (cdr buffers))))))

(defun tm:unformat-string (str)
  "Return STR with all % replaced with %%"
  (let ((start 0))
    (while (setq start (string-match "%" str start))
      (setq str (concat (substring str 0 start)
			"%"
			(substring str start)))
      (setq start (+ start 2)))
    str))

(defun tm:file-member (file files)
  "Return T if FILE is a member of FILES; use inode number to identify
files."
  (or (member file files)
      (let ((inode (nth 10 (file-attributes file)))
	    (result ()))
	(and inode
	     (progn
	       (while (and files (null result))
		 (let* ((file2 (car files))
			(inode2 (nth 10 (file-attributes file2))))
		   (setq result (eq inode inode2))
		   (setq files (cdr files))))
	       result)))))

(if (not (fboundp 'tm:original-get-file-buffer))
    (fset 'tm:original-get-file-buffer (symbol-function 'get-file-buffer)))

(fset 'get-file-buffer 'tm:get-file-buffer)

(defun tm:get-file-buffer (file)
  "Same as get-file-buffer, but looks for files inodes."
  (or (tm:original-get-file-buffer file)
      (let ((file-inode ())
	    (basename (file-name-nondirectory file))
	    (buffers (buffer-list)))
	(catch 'result
	  (while buffers
	    (let* ((buffer (car buffers))
		   (buffer-file (buffer-file-name buffer)))
	      (if (and buffer-file
		       (string= (file-name-nondirectory buffer-file) basename)
		       (eq (tm:real-file-inode buffer-file)
			   (setq file-inode
				 (or file-inode
				     (or (tm:real-file-inode file)
					 (throw 'result ()))))))
		  (throw 'result buffer)
		(setq buffers (cdr buffers)))))
	  ()))))

(defun tm:real-file-inode (file)
  "Return the inode of FILE, resolving symbolic links."
  (let ((real ()))
    (while (setq real (file-symlink-p file))
      (setq file real))
    (nth 10 (file-attributes file))))

(defun tm:real-file-mtime (file)
  "Return the modification time of FILE as a pair (high . low), resolving
symbolic links, or () if the file does not exits."
  (let ((real ()))
    (while (setq real (file-symlink-p file))
      (setq file real))
    (nth 5 (file-attributes file))))

(defun tm:find-file-noselect (file)
  "Same as find-file-noselect, but more clever; it identifies files by their
inode."
  (or (tm:get-file-buffer file)
      (find-file-noselect file)))

(defun tm:process-dead-p (process)
  "Test wether PROCESS is dead."
  (memq (process-status process) '(exit signal closed ())))

(defun tm:insert-centered-title (title)
  "Insert a centered TITLE."
  (let ((column (/ (- (window-width) (length title) 10) 2))
	(char (aref title 0)))
    (aset title 0 (upcase char))
    (indent-to-column column)
    (tm:insert-title title)
    (aset title 0 char)))

(defun tm:delete-window (window)
  "Delete WINDOW."
  (let ((solep (eq window (next-window window ()))))
    (cond
     ((and solep tml:other-screen-p)
      (tm:delete-screen))
     ((not solep)
      (delete-window window))
     (t
      (show-buffer window (other-buffer (window-buffer window)))))))

(defun tm:new-buffer-name (buffer-format)
  "Return a the name of a non-existing buffer with format BUFFER-FORMAT."
  (tm:formatted-buffer-name buffer-format (tm:new-buffer-count buffer-format)))

(defun tm:new-buffer-count (buffer-format)
  "Return a unique count for a buffer with format name BUFFER-FORMAT."
  (let ((count 0))
    (while (get-buffer (tm:formatted-buffer-name buffer-format count))
      (setq count (+ count 1)))
    count))

(defun tm:formatted-buffer-name (buffer-format count)
  "Return the name of a buffer with format BUFFER-FORMAT and count COUNT."
  (if (= count 0)
      (format buffer-format "")
    (format buffer-format (concat "<" count ">"))))

(defun tm:show-buffer (buffer &optional herep selectp where)
  "Show BUFFER in another window if not already visible. If optional HEREP
is true, use the current window to show the buffer if not visible.
If optional SELECTP is true, select this buffer. If optional WHERE is
BEGIN, go to the beginning of the buffer. If WHERE is END, go to the end
of the buffer.
Return the window associated to the buffer."
  (let ((window (or (tm:get-buffer-window buffer)
		    (tm:display-buffer buffer herep))))
    (if selectp
	(progn
	  (tm:select-window window)
	  (tm:goto-position window where))
      (tm:goto-position window where))
    (tm:raise-window-screen window)
    window))

(defun tm:goto-position (window where)
  (cond
   ((eq where 'begin)
    (let ((min (save-excursion
		 (set-buffer (window-buffer window))
		 (point-min))))
      (if (not (tm:pos-visible-in-window-p min window))
	  (set-window-start window min))))
   ((eq where 'end)
    (let ((max (save-excursion
		 (set-buffer (window-buffer window))
		 (point-max))))
      (if (not (tm:pos-visible-in-window-p max window))
	  (set-window-point window max))))))

(defun tm:pos-visible-in-window-p (pos window)
  "Replacement for pos-visible-in-window-p, which seems buggy, at
least on emacs19, and signals random errors."
  (condition-case ()
      (pos-visible-in-window-p pos window)
    (error t))) ; So that no set-window-point is attempted


;; Program unit files and buffers
;; ------------------------------
;;

(defun tm:file-extension (file)
  "Return the extension of FILE, or () if there isn't."
  (let ((match (string-match "\\.[^.]*$" file)))
    (and match (substring file match))))

(defun tm:file-without-extension (file)
  "Return FILE without its extension."
  (let ((match (string-match "\\.[^.]*$" file)))
    (if (null match)
	file
      (substring file 0 match))))

(defun tm:source-file-p (file)
  "Return T if FILE is a source file."
  (string-match tm:talk-source-file-regexp file))

(defun tm:source-buffer-p (buffer)
  "Return T if BUFFER edits a source file."
  (let ((file (buffer-file-name buffer)))
    (and file (tm:source-file-p file))))

(defun tm:desc-file-p (file)
  "Return T if FILE is a description file."
  (string-match tm:talk-desc-file-regexp file))

(defun tm:test-file-p (file)
  "Return T if FILE is a test file."
  (string-match tm:talk-test-file-regexp file))

(defun tm:buffer-program-unit (buffer &optional no-error-p)
  "Return the name of the program unit associated with BUFFER.
If BUFFER is not a program unit buffer, and optional NO-ERROR-P is T,
return (); otherwise, signal an error."
  (let* ((file (buffer-file-name buffer))
	 (prunit (and file (tm:file-program-unit file))))
    (cond
     (prunit)
     (no-error-p ())
     (t (error "%s is not a program unit file buffer"
	       (buffer-name buffer))))))

(defun tm:prunit-buffer-p (buffer)
  "Return T if BUFFER is editing a program unit."
  (let ((file (buffer-file-name buffer)))
    (and file
	 (or (tm:source-file-p file)
	     (tm:desc-file-p file)
	     (tm:test-file-p file)))))

(defun tm:file-program-unit (file)
  "Return the name of the program unit associated with FILE, or ()
if there isn't."
  (if (or (string-match tm:talk-source-file-regexp file)
	  (string-match tm:talk-desc-file-regexp file)
	  (string-match tm:talk-test-file-regexp file))
      (substring file (match-beginning 1) (match-end 1))
    ()))

(defun tm:current-buffer-program-unit (&optional no-error-p)
  "Return the name of the program unit associated with the current buffer.
For no-error-p, see tm:buffer-program-unit"
  (tm:buffer-program-unit (current-buffer) no-error-p))

(defun tm:program-unit-source-buffers (name)
  "Return the list of buffers editing the source and description files of the
program unit NAME."
  (tm:buffers-with-files-matching
   (format tm:talk-source-file-regexp-format name)))

(defun tm:program-unit-buffers (name)
  "Return the list of buffers editing the source and description files of the
program unit NAME."
  (nconc (tm:buffers-with-files-matching
	  (format tm:talk-source-file-regexp-format name))
	 (tm:buffers-with-files-matching
	  (format tm:talk-desc-file-regexp-format name))
	 (tm:buffers-with-files-matching
	  (format tm:talk-test-file-regexp-format name))))

(defun tm:buffers-with-files-matching (regexp)
  "Return the list of buffers editing files matching with regexp."
  (let ((result ())
	(buffers (buffer-list)))
    (while buffers
      (let* ((buffer (car buffers))
	     (file (buffer-file-name buffer)))
	  (if (and file (string-match regexp file))
	      (setq result (cons buffer result))))
      (setq buffers (cdr buffers)))
    result))

(defun tm:file-desc-file (file)
  "Return the descriptor file associated with FILE, of () if we cannot
find it. The latter case can occur only for test files, since the descriptor
file is not necessarily in the same directory as the test file --- so all
we can do is heuristic."
  (cond
   ((tm:desc-file-p file)
    file)
   ((tm:source-file-p file)
    (tm:source-file-desc-file file))
   ((tm:test-file-p file)
    (tm:test-file-desc-file file))
   (t
    ())))

(defun tm:test-file-desc-file (test-file)
  "Return the name of the descriptor associated with TEST-FILE
if it can be found in the current directory or in edited buffers,
or () otherwise."
  (let ((desc-file-same-dir
	 (concat (tm:file-without-extension test-file)
		 tm:talk-desc-extension)))
    (if (file-exists-p desc-file-same-dir)
	desc-file-same-dir
      (let* ((name (tm:file-program-unit test-file)))
	(let (bufs)
	  (cond
	    ((setq bufs
	       (tm:buffers-with-files-matching
		(format tm:talk-source-file-regexp-format name)))
	     (let ((src-file (buffer-file-name (car bufs))))
	       (concat (tm:file-without-extension src-file)
		       tm:talk-desc-extension)))
	    ((setq bufs
	       (tm:buffers-with-files-matching
		(format tm:talk-desc-file-regexp-format name)))
	     (buffer-file-name (car bufs)))
	    (t
	     ())))))))

(defun tm:source-file-desc-file (source-file)
  "Return the name of the descriptor file associated with SOURCE-FILE."
  (concat (tm:file-without-extension source-file) tm:talk-desc-extension))

(defun tm:desc-file-source-file (desc-file)
  "Return the name of the source file associated with DESC-FILE."
  (concat (tm:file-without-extension desc-file) tm:talk-source-extension))

(defun tm:desc-file-readable-source-file (desc-file)
  "Return the source file associated with the descriptor file desc-file.
If it does not exits or is not readable, return ()."
  (let ((file (tm:desc-file-source-file desc-file)))
    (and (file-readable-p file)
	 file)))

; Currently not used
(defun tm:which-file (dirs name extension)
  "Look for a file with name NAME and extension EXTENSION in DIRS."
  (catch 'found
    (while dirs
      (let ((dir (car dirs)))
	(setq dirs (cdr dirs))
	(let ((file (concat dir "/" name extension)))
	  (if (file-exists-p file)
	      (throw 'found file)))))
    ()))


;; Symbols and s-expressions
;; -------------------------
;;

(defun tm:symbol-at-point-string (errorp)
  "Return the symbol at point as a string. If the current expression
is not a symbol, then if ERRORP is true signal an error, else return ()."
  (let* ((pair (tm:sexp-at-point t)))
    (if (null pair)
	(if errorp
	    (error "Not standing on a symbol")
	  ())
      (buffer-substring (car pair) (cdr pair)))))

(defun tm:sexp-at-point (&optional symbolp)
  "Return a pair with current expression start and end positions. If optional
SYMBOLP is true and the current expression is not a symbol, return ()."
  (save-excursion
    (if (or (tm:standing-on-symbol-char-p)
	    (tm:standing-on-sexp-start-p)
	    (tm:empty-to-bol-p))
	(condition-case ()
	    (forward-sexp 1)
	  (error ())))
    (condition-case ()
	(forward-sexp -1)
      (error ()))
    (if symbolp
	(tm:sexp-at-point-symbol)
      (tm:sexp-at-point-other))))

(defun tm:sexp-at-point-symbol ()
  "Do the job for tm:sexp-at-point with SYMBOLP true."
  (tm:skip-macro-characters  )
  (let ((start (point)))
    (if (not (tm:standing-on-symbol-char-p))
	()
      (forward-sexp 1)
      (cons start (point)))))

(defun tm:sexp-at-point-other ()
  "Do the job for tm:sexp-at-point with SYMBOLP false."
  (let ((start (point)))
    (tm:skip-macro-characters)
    (forward-sexp 1)
    (cons start (point))))

(defun tm:skip-macro-characters ()
  "Skip macro characters and macro sequences"
  (condition-case ()
      (progn
	(skip-chars-forward "`'")
	(let ((c (char-after (point))))
	  (cond
	    ((eq c ?,)
	     (forward-char 1)
	     (if (eq (char-after (point)) ?@)
		 (forward-char 1)))
	    ((eq c ?#)
	     (forward-char 2)))))
    (error ())))

(defun tm:standing-on-symbol-char-p ()
  "Return true if the current character is a symbol constituent."
  (and (not (eobp))
       (memq (char-syntax (char-after (point))) '(?w ?_))))

(defun tm:standing-on-sexp-start-p ()
  "Return true if the current character begins a s-expression."
  (and (not (eobp))
       (memq (char-syntax (char-after (point))) '(?( ?\\ ?'))))

(defun tm:empty-to-bol-p ()
  "Return true if the line is empty between the beginning of the
line and the point."
  (save-excursion
    (skip-chars-backward " \t")
    (bolp)))

(defun tm:explode-symbol (symbol read-package-buffer)
  "Return a pair (package . pname) for SYMBOL. If the symbol is not
packaged, then package is (). READ-PACKAGE-BUFFER is the buffer whose
read-package can be used if needed. If the symbol has implicit package and
read-package is unknown, then package is the symbol unknown."
  (let ((package-index (string-match "^\\(\\_\\|\\w\\|\\.\\)*\\." symbol)))
    (cond
     ((null package-index)
      (cons () symbol))
     (t
      (let* ((colon (match-end 0))
	     (pname (substring symbol colon)))
	(cond
	 ((= colon 1)
	  (let ((read-package (tm:buffer-read-package read-package-buffer)))
	    (if (eq read-package 'unknown)
		(cons 'unknown pname)
	      (cons read-package pname))))
	 (t
	  (let ((package (substring symbol 0 (- colon 1))))
	    (cons package pname)))))))))

(defun tm:make-symbol (package pname &optional read-package)
  "Return a string representing the symbol with PNAME and PACKAGE. If
READ-PACKAGE is provided, then the symbol is possibly returned with
implicit package."
  (cond
   ((null package)
    pname)
   ((eq package 'unknown)
    (if (stringp read-package)
	(concat read-package "." pname)
      (concat "." pname)))
   (t
    (if (and (stringp read-package)
	     (string= read-package package))
	(concat "." pname)
      (concat package "." pname)))))
    
(defun tm:end-of-defun ()
  "Go to the end of the current defun. If the current defun is not complete,
look for the first blank line after point."
  (interactive)
  (let ((here (point)))
    (tm:beginning-of-defun)
    (let ((completep t))
      (condition-case ()
	  (forward-sexp 1)
	(error (setq completep ())))
      (if (not completep)
	  (progn
	    (goto-char here)
	    (if (looking-at "^\\s(")
		(forward-char 1))
	    (let ((limit (point)))
	      (or (re-search-forward "^\\s(" () t)
		  (goto-char (point-max)))
	      (while (and (>= (point) limit)
			  (re-search-backward "\\(^;\\|^\\s *$\\)" limit t))
		(forward-line -1)
		(beginning-of-line))
	      (end-of-line)))))))

(defun tm:get-comment-region (paragraphp)
  "If point is in a comment, return a list (prefix begin end) enclosing the
comment, otherwise return (). If PARAGRAPHP is true, limit the region
to the enclosing commented paragraph."
  (save-excursion
    (beginning-of-line)
    (if (not (looking-at tm:comment-line-regexp))
	()
      (let* ((comment-prefix (buffer-substring (point) (match-end 0)))
	     (comment-regexp
	      (concat "^" (regexp-quote comment-prefix)))
	     (empty-comment-regexp
	      (if paragraphp (concat comment-regexp "\\s *$") "\'")))
	(let ((current (point))
	      (begin (point)))
	  (while (and (not (bobp))
		      (progn
			(forward-line -1)
			(if (and (looking-at comment-regexp)
				 (not (looking-at empty-comment-regexp)))
			    t
			  (forward-line 1)
			  ()))))
	  (setq begin (point))
	  (goto-char current)
	  (while (and (not (eobp))
		      (progn
			(forward-line 1)
			(and (looking-at comment-regexp)
			     (not (looking-at empty-comment-regexp))))))
	  (list comment-prefix begin (point)))))))

(defun tm:basic-beginning-of-defun ()
  "Go to the beginning of the current toplevel form."
  (if (not (looking-at "^("))
      (beginning-of-defun)))

;; To be redefined in talk-process.el
(defun tm:beginning-of-defun ()
  "Go to the beginning of the current toplevel form."
  (interactive)
  (tm:basic-beginning-of-defun))

(defun tm:index (elt list)
  "Return the index of ELT in LIST, or () if it is not in LIST."
  (let ((i 0)
	(result ()))
    (while (and list (null result))
      (if (eq elt (car list))
	  (setq result i)
	(setq i (1+ i))
	(setq list (cdr list))))
    result))

(defun tm:last-elt (list)
  "Return the last element of LIST; () if the list is empty."
  (while (cdr list) (setq list (cdr list)))
  (car list))


;; Indentation rules
;; -----------------
;;

(defun tm:define-indentation-rules (rule list)
  (while list
    (put (car list) tm:indent-property rule)
    (setq list (cdr list))))

(tm:define-indentation-rules 
 1
 '(block catch for prog1 lambda let let* while withf unless
	 debug-assert assert dynamic-let dynamic-compiler-let when case
	 throw generic-lambda method-lambda destructuring-let
	 with-handler defmessage repeat show-profiling show-memory-delta
	 unwind-protect flet labels return-from cpp-let cpp-let*
 	 with-posix-streams))

(tm:define-indentation-rules 
 'defun
 '(defun defclass defgeneric defmethod setf pushf psetf setq incf decf
    \.named-lambda define-cpp-class progv define-handler-method define
    defpredicate defconstructor defextern defstructure defaccessor
    defaccessor-macro trap-error predefun))

(tm:define-indentation-rules 
 2
 '(if))

(tm:define-indentation-rules 
 0
 '(progn tagbody cond collecting case-level when-debug or and
	 with-frozen-td-cache))

(provide 'talk-mode)

