;; This is my personal .emacs, with lots of self-penned and stolen
;; tidbits to make life in the editor more pleasant for a German who
;; hacks CDG files. It also tries to cater to both XEmacs and FSF
;; emacs, but it's a losing battle.



;; Enable the commands `narrow-to-region' ("C-x n n") and 
;; `eval-expression' ("M-:", or "ESC :").  Both are useful
;; commands, but they can be confusing for a new user, so they're
;; disabled by default.
(put 'narrow-to-region 'disabled nil)
(put 'eval-expression  'disabled nil)

;;;
;;; Code for FSF emacs goes here
;;;
(if (not (featurep 'xemacs))

    ;; This is to prevent GNU emacs from trying to load backup-dir.el,
    ;; which it doesn't have, but which is mentioned in my
    ;; customization list.
    (provide 'backup-dir)

  )


;; Most of the require's in this file are not really required, just
;; convenient to have. But when a package require fails it
;; stops processing of the .emacs file, leaving me with a 
;; really strange (uncustomized) editor. So instead of requiring those 
;; packages I just *try* to require them.
(defun try-to-load (package)
  "Require a package but don't throw an error if it isn't there."
  (condition-case 
      var
      (require package)
    (t (progn 
         (message "WARNING: couldn't load package `%s'." package)
         nil))))



;;; Code for XEmacs goes here. Note that some of this was deliberately
;;; not done using customize, so it won't spoil the customization
;;; list for GNU.
(if (featurep 'xemacs)
    (progn 

      ;; compatible ange-ftp/efs initialization derived from code
      ;; from John Turner <turner@lanl.gov>
      ;; As of 19.15, efs is bundled instead of ange-ftp.
      ;; NB: doesn't handle 20.0 properly, efs didn't appear until 20.1.
      ;;
      ;; The environment variable EMAIL_ADDRESS is used as the password
      ;; for access to anonymous ftp sites, if it is set.  If not, one is
      ;; constructed using the environment variables USER and DOMAINNAME
      ;; (e.g. turner@lanl.gov), if set.
      (if (or (and (= emacs-major-version 20) (>= emacs-minor-version 1))
              (and (= emacs-major-version 19) (>= emacs-minor-version 15)))
          (if (try-to-load 'efs-auto)
              (progn
                (message "Loading and configuring bundled packages... efs")
                (if (getenv "USER")
                    (setq efs-default-user (getenv "USER")))
                (if (getenv "EMAIL_ADDRESS")
                    (setq efs-generate-anonymous-password (getenv "EMAIL_ADDRESS"))
                  (if (and (getenv "USER")
                           (getenv "DOMAINNAME"))
                      (setq efs-generate-anonymous-password
                            (concat (getenv "USER")"@"(getenv "DOMAINNAME")))))
                (setq efs-auto-save 1))
            )
        )

      ;; ********************
      ;; Load the default-dir.el package which installs fancy handling
      ;;  of the initial contents in the minibuffer when reading
      ;; file names.
      (if (or (and (= emacs-major-version 20) (>= emacs-minor-version 1))
              (and (= emacs-major-version 19) (>= emacs-minor-version 15)))
          (try-to-load 'default-dir))

      ;; keeps cursor in place when scrolling
      (load-library "scroll-in-place")

      ;; Load crypt, which is a package for automatically decoding and
      ;; reencoding files by various methods - for example, you can
      ;; visit a .Z or .gz file, edit it, and have it automatically
      ;; re-compressed when you save it again.
      (setq crypt-encryption-type 'pgp	; default encryption mechanism
            crypt-confirm-password t	; make sure new passwords are correct
            crypt-never-ever-decrypt t ; if you don't encrypt anything, set this to
					; tell it not to assume that "binary" files
					; are encrypted and require a password.
            crypt-auto-write-buffer t)
      (try-to-load 'crypt)

      ;; If many minor modes are active simultaneously, the modeline
      ;; may overflow. But I want to see the line/column number info
      ;; at all times, so I place it at the left where it can't be
      ;; pushed away by other info.
      (setq default-modeline-format
            (list
             (cons modeline-modified-extent 'modeline-modified)
             " "
             (list 'line-number-mode "L%l ")
             (list 'column-number-mode "C%c ")
             (cons modeline-buffer-id-extent 'modeline-buffer-identification)
             'global-mode-string
             " %[("
             (list modeline-minor-mode-extent "" 'mode-name 'minor-mode-alist)
             (cons modeline-narrowed-extent "%n")
             'modeline-process
             ")%]-%p-%-"))

      ;; When running ispell, consider all 1-3 character words as correct.
      (setq ispell-extra-args '("-W" "3"))

      (cond ((or (not (fboundp 'device-type))
                 (equal (device-type) 'x))
             ;; Code which applies only when running emacs under X
             ;; goes here. (We check whether the function
             ;; `device-type' exists before using it. In versions
             ;; before 19.12, there was no such function. If it
             ;; doesn't exist, we simply assume we're running under X
             ;; -- versions before 19.12 only supported X.)


             ;; This changes the variable which controls the text that goes
             ;; in the top window title bar.
             (setq frame-title-format
                   (concat "XEmacs " 
                           (int-to-string emacs-major-version)
                           "."
                           (int-to-string emacs-minor-version)
                           ":  %f"))
	     
             ;; Change the pointer used when the mouse is over a modeline
             (set-glyph-image modeline-pointer-glyph "leftbutton")

             ;; Change the continuation glyph face so it stands out more
             (and (fboundp 'set-glyph-property)
                  (boundp 'continuation-glyph)
                  (set-glyph-property continuation-glyph 'face 'bold))

             ;; Change the pointer used during garbage collection.
             ;;
             ;; Note that this pointer image is rather large as pointers go,
             ;; and so it won't work on some X servers (such as the MIT
             ;; R5 Sun server) because servers may have lamentably small
             ;; upper limits on pointer size.
             ;;(if (featurep 'xpm)
             ;;   (set-glyph-image gc-pointer-glyph
             ;;	 (expand-file-name "trash.xpm" data-directory)))

             ;; Here's another way to do that: it first tries to load the
             ;; pointer once and traps the error, just to see if it's
             ;; possible to load that pointer on this system; if it is,
             ;; then it sets gc-pointer-glyph, because we know that
             ;; will work.  Otherwise, it doesn't change that variable
             ;; because we know it will just cause some error messages.
             (if (featurep 'xpm)
                 (let ((file (expand-file-name "recycle.xpm" data-directory)))
                   (if (condition-case error
                           ;; check to make sure we can use the pointer.
                           (make-image-instance file nil
                                                '(pointer))
                         (error nil))   ; returns nil if an error occurred.
                       (set-glyph-image gc-pointer-glyph file))))
	 
             ;; Add `dired' to the File menu
             (add-menu-button '("File") ["Edit Directory" dired t])

             )
            )

      ;; func-menu displays the current function in the modeline 
      ;; and adds menu items to navigate them
      (if (try-to-load 'func-menu)
          (progn 
            (add-hook 'find-file-hooks 'fume-add-menubar-entry)
            (define-key global-map "\C-cl" 'fume-list-functions)
            (define-key global-map "\C-cg" 'fume-prompt-function-goto)
            (define-key global-map '(shift button3) 'mouse-function-menu)
            ))

      ;; Not using rsz-minibuf means having to type blindly whenever
      ;; more than one line of input is necessary.
      (if (try-to-load 'rsz-minibuf)
          (setq-default resize-minibuffer-mode t))

      ;; Display time, date, load, mail etc. in modeline
      (try-to-load 'time)

      ;; Make M-x d-f-a expand to describe-face-at-point
      (try-to-load 'completer)

      ;; allow external processes to create XEmacs frames
      (gnuserv-start)

      ;; helps in spotting the cursor
      (blink-cursor-mode 1)
      
      ;; centralize backups
      (setq bkup-backup-directory-info (quote (("^" "~/.backup" ok-create))))

      ;; XEmacs tetris lacks the `down' command, so add it on key d
      (if (try-to-load 'tetris)
          (progn
            (define-key tetris-mode-map "d" 'tetris-move-down)
            (defun tetris-move-down ()
              "Lowers the shape by one step"
              (interactive)
              (tetris-erase-shape)
              (incf tetris-pos-y)
              (tetris-draw-shape))))
            
      (try-to-load 'ffap)
      (try-to-load 'filladapt)

      ;; fontify user-defined types
      (if (try-to-load 'ctypes)
          (progn
            (setq ctypes-write-types-at-exit t)
            (ctypes-read-file nil nil t t)
            (ctypes-auto-parse-mode 1)))

      ))

;; Older versions of emacs did not have these variables
;; (emacs-major-version and emacs-minor-version.)
;; Let's define them if they're not around, since they make
;; it much easier to conditionalize on the emacs version.

(if (and (not (boundp 'emacs-major-version))
	 (string-match "^[0-9]+" emacs-version))
    (setq emacs-major-version
	  (string-to-int (substring emacs-version
				    (match-beginning 0) (match-end 0)))))
(if (and (not (boundp 'emacs-minor-version))
	 (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version))
    (setq emacs-minor-version
	  (string-to-int (substring emacs-version
				    (match-beginning 1) (match-end 1)))))

;; Remove or convert trailing ctl-M
(add-hook 'find-file-hooks 'remove-trailing-ctl-M)
(defun remove-trailing-ctl-M ()
  "Propose to remove trailing ^M from a file."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (if (and (not (string-match ".gz$" (buffer-file-name)))
             (search-forward-regexp "\015$" nil t))
                                        ;: a ^M is found
        (if (or (= (preceding-char) ?\^J)
                (= (following-char) ?\^J) )
            (if (y-or-n-p (format "Remove trailing ^M from %s? " 
                                  (buffer-file-name)))
                (progn (goto-char (point-min))
                       (perform-replace "\015" "" nil nil nil)
                       (pop-mark) 
                       (save-buffer))
              (message "No transformation."))))))


;; This is just to enable the Perl::Run menu entry
;; (http://wuarchive.wustl.edu/languages/elisp/misc/mode-compile.el.Z)
(autoload 'mode-compile "mode-compile"
  "Command to compile current buffer file based on the major mode" t)
(autoload 'mode-compile-kill "mode-compile"
  "Command to kill a compilation launched by `mode-compile'" t)

;;; general
(cd "~")

;; find private elisp code
(add-to-list 'load-path "/home/foth/")
(add-to-list 'load-path "/home/foth/.elisp")

;; superintelligent alignment (http://www.emacs.org/~johnw/emacs.html)
(try-to-load 'align)

;; close lisp brackets automatically
;; (http://x62.deja.com/[ST_rn=ps]/getdoc.xp?AN=532659685&CONTEXT=963831927.188678371&hitnum=0)
;; (try-to-load 'superbracket)

;; So that the menu option won't start greyed out
(try-to-load 'vc-hooks)


;; install German umlauts
(iso-accents-mode)
(iso-accents-customize "german")

;; make dired recognize German month names
(if (try-to-load 'dired)
    (setq dired-re-month-and-time
          (concat
           "\\(Jan\\|Feb\\|M.r\\|Apr\\|Ma.\\|June?\\|July?\\|Aug\\|Sep\\|O.t\\|Nov\\|"
					; June and July are for HP-UX 9.0
           "De.\\) [ 0-3][0-9]\\("
           " [012][0-9]:[0-6][0-9] \\|" ; time
           " [12][90][0-9][0-9] \\|"    ; year on IRIX, NeXT, SunOS, ULTRIX, Apollo,
                                        ; HP-UX, A/UX
           " [12][90][0-9][0-9]  \\)"   ; year on AIX
           )))


;; Font-Lock is a syntax-highlighting package.  When it is enabled and you
;; are editing a program, different parts of your program will appear in
;; different fonts or colors.  For example, with the code below, comments
;; appear in red italics, function names in function definitions appear in
;; blue bold, etc.  The code below will cause font-lock to automatically be
;; enabled when you edit C, C++, Emacs-Lisp, and many other kinds of
;; programs.
(setq font-lock-use-default-fonts nil)
(setq font-lock-use-default-colors t)
  

;; file naming conventions
(setq auto-mode-alist
      (append '(("\\.pl$" . prolog-or-perl-mode)
		("\\.pro$". prolog-mode)
		("\\.cd.$". cdg-mode)
		("\\.m4$" . cdg-mode))
	      auto-mode-alist))

;; default tag set
(visit-tags-table "~/cdg/")

;; keybindings
;; F1 belongs to olwm
(global-set-key [f2] 'save-buffer)
;; F3 belongs to olwm
(global-set-key [f4] 'font-lock-fontify-buffer)
(global-set-key [(shift f3)] (lambda () (interactive)
                               (switch-to-buffer "*scratch*")))
(global-set-key [f5] 'fill-paragraph)
(global-set-key [f6] 'repeat-last-shell-command)
(global-set-key [f7] 'query-replace-regexp)
(global-set-key [f9] 'compile)
(global-set-key [f10] 'toggle-debug-on-error)
(global-set-key [f11] 'vm)
(global-set-key [f12] 'ediff-buffers)
(global-set-key [(shift f12)] 'ediff-revision)

(define-key read-expression-map [(shift tab)] 'lisp-complete-symbol)
(define-key minibuffer-local-map [(shift tab)] 'lisp-complete-symbol)
(define-key minibuffer-local-completion-map [(shift tab)]
'lisp-complete-symbol) (define-key minibuffer-local-must-match-map
[(shift tab)] 'lisp-complete-symbol)


;; Never iconify...
(global-unset-key [(control z)])
(global-unset-key [(control x) (control z)])

;; ...never quit by mistake...
(global-set-key [(control x) (control c)] 
  (function 
   (lambda () (interactive) 
     (cond ((y-or-n-p "Quit editor? ")
            (save-buffers-kill-emacs))))))

;; ...never switch to overwrite mode, not even accidentally
(global-set-key [insert] 
  (function 
   (lambda () (interactive) 
     (message "Sorry, overwrite mode has been disabled forever."))))

;; make HOME and END work like God intended
(global-set-key [home] 'beginning-of-line)
(global-set-key [end] 'end-of-line)

;; make M-SPC fixup whitespace
(global-set-key [(meta space)] 'just-one-space)
(global-set-key [(meta d)] 
  (function (lambda () (interactive)
              (let ((space-desired 
                     (or (= ?\ (char-syntax (char-before)))
                         (= ?\ (char-syntax (char-after))))))
                (kill-word 1)
                (if space-desired
                    (just-one-space))))))

(global-set-key [(meta backspace)] 
  (function (lambda () (interactive)
              (let ((space-desired 
                     (and (not (looking-at "$"))
                          (or (= ?\ (char-syntax (char-before)))
                              (= ?\ (char-syntax (char-after)))))))
                (backward-kill-word 1)
                (if space-desired
                    (just-one-space))))))

;; make M-[ and M-] scroll paragraphs in place
(global-set-key [(meta ?\[)] 'back-par-in-place)
(global-set-key [(meta ?\])] 'forward-par-in-place)

(global-set-key [(meta tab)] 'my-indent-relative)

;; search through tagged files
(global-set-key [(control ?.)] 'tags-search)

;; kill from point to the preceding instance of CHAR
(global-set-key [(control meta z)] 'zap-from-char)

;; cancel case-fold-search for one search
(global-set-key [(control alt meta s)] 
  (function
   (lambda () (interactive)
     (let ((case-fold-search nil))
       (call-interactively 'isearch-forward-regexp)))))

;; split windows should display different buffers
(global-set-key [(control x) \2] 'split-window-switch-buffer)
(global-set-key [(control x) \3] 'hsplit-window-switch-buffer)

;; selective yanking (see selective-yank below)
(global-set-key [(alt y)] 
  (function 
   (lambda () (interactive)
     (if (eq last-command 'selective-yank)
         (selective-yank-pop)
       (call-interactively 'selective-yank)))))

;; better buffer cycling
(global-set-key [(control return)] 'forward-buffer)
(global-set-key [(shift return)]  'backward-buffer)

;; repeat last replace command
(global-set-key [(control ?\%)] 'repeat-last-replace)

(global-set-key [(control c) (control r)] 'comment-region)
(global-set-key [(control x) (control i)] 'quoted-insert-file)
(global-set-key [(control i)] 'split-quoted-line)

;; TAB expands even during isearch
(define-key isearch-mode-map [tab] 'isearch-yank-word)

;;; functions

(defun kill-buffers (regexp) 
  (interactive "sKill buffers: ")
  "Kill buffers matching REGEXP."
  (mapcar
   (function
    (lambda (buffer) 
      (let ((name (buffer-file-name buffer)))
        (if (and name (string-match regexp name))
            (kill-buffer buffer)))))
   (buffer-list)))


;; cycle through buffers, ignoring uninteresting ones
(defun backward-buffer () (interactive)
  "Switch to previously selected buffer."
  (let* ((list (cdr (buffer-list)))
         (buffer (car list)))
    (while (and (cdr list) (string-match "\\*" (buffer-name buffer)))
      (progn
        (setq list (cdr list))
        (setq buffer (car list))))
    (bury-buffer)
    (switch-to-buffer buffer)))


(defun forward-buffer () (interactive)
  "Opposite of backward-buffer."
  (let* ((list (reverse (buffer-list)))
         (buffer (car list)))
    (while (and (cdr list) (string-match "\\*" (buffer-name buffer)))
      (progn
        (setq list (cdr list))
        (setq buffer (car list))))
    (switch-to-buffer buffer)))


;; debug at a keypress
(defun toggle-debug-on-error () (interactive)
  (setq debug-on-error (not debug-on-error))
  (message (concat 
            "Error debugging "
            (if debug-on-error "on." "off.")))
  )

(defun kill-buffer-and-window ()
  "Kill the current buffer and delete the selected window."
  (interactive)
  (let ((buffer (current-buffer)))
    (delete-window (selected-window))
    (kill-buffer buffer))
  )

;; let split windows display different buffers
(defun split-window-switch-buffer () (interactive)
  "Split current window and display the two last buffers used."
  (split-window)
  (switch-to-buffer (other-buffer (current-buffer)))
  )

(defun hsplit-window-switch-buffer () (interactive)
  "Split current window horizontally and display the two last buffers used."
  (split-window-horizontally)
  (switch-to-buffer (other-buffer (current-buffer)))
  )

(defun insert-paragraph-glyph () (interactive)
  "Make inserting '§' easier."
  (insert-string "§"))

(defun sgdh () (interactive)
  "Start business correspondence."
  (insert-string "Sehr geehrte Damen und Herren,\n\n"))
(defun mfg () (interactive)
  "End business correspondence."
  (insert-string "Mit freundlichen Grüßen,\n\nKilian A. Foth"))

;; There are two useful hings that I would like TAB to do:
;;
;; a) indent according to the current major mode's notion of nesting
;;
;; b) complete a word as under readline.
;;
;; I use the text around point as a cue what it is that I want from the
;; editor. Allowance has to be made for the case that point is at the
;; edge of a buffer.
(defun indent-or-expand () 
  "Either indent according to mode, or expand the word preceding point."
  (interactive)
  (if (and
       (= ?w (char-syntax (char-before)))
       (not (= ?w (char-syntax (char-after)))))
      (dabbrev-expand nil)
    (indent-according-to-mode)))

(defun verbify (&optional n) (interactive "*P")
  "Wrap a LaTeX \\verb command around N last words."
  (skip-chars-backward " ")
  (let ((expression 
         (progn
           (let ((beg (point)))
             ;; skip n words backwards
             (search-backward-regexp "^\\| " nil nil n)
             (skip-chars-forward " ")
             ;; delete & remember N last words
             (kill-region beg (point))
             (current-kill 0))))
	(delims "=|+~-_!#@.")
	(delim "")
	(i 0))
    ;; try very hard to find a fitting delimiter for the \verb command
    (while (and (< i (length delims))
		(string-match delim expression))
      (setq delim (substring delims i (1+ i)))
      (incf i))
    ;; still no success?					
    (if (string-match delim expression) 
	(message "That's one hell of a weird string you're trying to verbify..."))
    ;; re-insert verbified expression
    (insert-string		
     (format "\\verb%s%s%s" delim expression delim)) 
    )
  )


;; Insert a javadoc comment
(defun java-insert-comment () (interactive)
  "insert /**  */ on a separate line and position point between it"
  (indent-according-to-mode)
  (insert-string "/**  */")
  (goto-char (- (point) 3))
  )


;; insert a C line comment
(defun c-insert-comment () (interactive)
  "insert /*  */ on a separate line and position point between it"
  (indent-according-to-mode)
  (insert-string "/*  */")
  (goto-char (- (point) 3))
  )

;; insert a printf statement
(defun c-insert-printf () (interactive)
  "insert cdgPrintf() statement on the current line"
  (indent-according-to-mode)
  (if (string-match "cdgPrintf" (buffer-string))
      (let ((mode (save-excursion
                    (if (re-search-backward "CDG_[A-Z]+")
                        (match-string 0)
                      "CDG_INFO"))))
        (insert-string (format "cdgPrintf(%s, \"\\n\");" mode)))
    (insert-string "printf(\"\\n\");" mode))
  (goto-char (- (point) 5)))

;; insert flagged debug statement
(defun insert-debug-clause () (interactive)
  "Insert a fresh debugging printf()-statement and position point in it"
  (c-indent-command)
  (insert-string "/* DEBUG */\n")
  (c-indent-command)
  (insert-string "cdgPrintf(CDG_DEBUG, \"\\n\");\n")
  (c-indent-command)
  (insert-string "/* DEBUG */\n")
  (c-indent-command)
  (previous-line 2)
  (forward-word 3)
  (forward-char 3)
  )

;; remove flagged debug statements
(defun delete-printfs () (interactive)
  "eliminate sections bounded by /* DEBUG */ <stuff> /* DEBUG */"
  (save-excursion
    (goto-char (point-min))
    (query-replace-regexp 
     "[\t\n ]*/\\* DEBUG \\*/[^/]+/\\* DEBUG \\*/[\t\n ]*\n" 
     "\n\n")))
;; This is a mostly straightforward regexp replacement. Note that we
;; also try to erase the whitespace with which the entire construction
;; is likely to be surrounded. But the final spaces following the
;; marker are most likely the indentation of the following statement,
;; so we make sure that the replaced text ends in a \n, leaving those
;; spaces alone. The entire operation fails if the bounded section 
;; contains a /.

;; zap-backwards, adapted from zap-to-char
(defun zap-from-char (arg char)
  (interactive "*p\ncZap from char: ")
  (kill-region (point) (progn
			 (search-backward (char-to-string char) nil nil arg)
			 (point))))

(defun debug-printfs-to-conditionals () (interactive)
  "transform flagged debug output into preprocessor conditionals"
  (query-replace-regexp 
   "\n* */\\* DEBUG \\*/\\([^/]+\\)/\\* DEBUG \\*/\n*" 
   "\n#ifdef DEBUGFOO\\1#endif\n")
  )

(defun c-insert-continue () (interactive)
  "Insert a continue statement with braces."
  (just-one-space)
  (insert-string "{")
  (indent-according-to-mode)
  (insert-string "\ncontinue;")
  (indent-according-to-mode)
  (insert-string "\n}")
  (indent-according-to-mode))

(defun c-insert-keyword (keyword condition) 
  "Insert a C block statement and the corresponding block."
  (insert (format "%s(%s)" keyword condition))
  (c-insert-block))

(defun c-insert-block () 
  "Insert a C block."
  (interactive)
  (indent-according-to-mode)
  (just-one-space)
  (insert-string "{\n\n}")
  (indent-according-to-mode)
  (previous-line 1)
  (indent-according-to-mode))

(defun c-insert-for (counter start stop) 
  "Write a standard for loop with counter."
  (interactive 
   "*sCounter variable (default i): \nsInitialization (default 0): \nsLimit: ")
  (if (string= "" counter) (setq counter "i"))
  (if (string= "" start) (setq start 0))
  (c-insert-keyword "for" (format "%s = %s; %s < %s; %s++"
                                  counter start counter stop counter)))

(defun c-insert-for-list (loopvar initvalue) 
  "Write a standard for loop about linked lists."
  (interactive "*sList variable (default l): \nsInitialization: ")
  (if (string= "" loopvar) (setq loopvar "l"))
  (c-insert-keyword 
   "for" (format "%s = %s; %s != NULL; %s = %s->next"
                 loopvar initvalue loopvar loopvar loopvar)))

(defun c-insert-if (condition) 
  "Insert a C if statement."
  (interactive "*sCondition: ")
  (c-insert-keyword "if" condition)
  )

(defun c-insert-else () 
  "Insert a C else clause."
  (interactive)
  (just-one-space)
  (insert "else")
  (c-insert-block)
  )

(defun c-insert-while (condition) 
  "Insert a C while statement."
  (interactive "*sCondition: ")
  (c-insert-keyword "while" condition)
  )

(defun c-insert-switch (condition) 
  "Insert a C switch statement."
  (interactive "*sExpression: ")
  (c-insert-keyword "switch" condition)
  )

(defalias 'tcl-insert-block 'c-insert-block)

(defun back-par-in-place () (interactive)
  (backward-paragraph)
  (recenter)
  )

(defun forward-par-in-place () (interactive)
  (forward-paragraph)
  (recenter)
  )


;; both prolog and perl files are often called .pl;
;; this tries to do the right thing.
(defun prolog-or-perl-mode () (interactive)
  (if
      (or (string-match "/perl\\b" (buffer-string)) ; file with perl header
          (= 1 (point-max)))            ; new file
      (progn	
        (cperl-mode)
        (message "Ambiguous suffix .pl resolved to perl mode."))
    (progn 
      (prolog-mode)
      (message "Ambiguous suffix .pl resolved to prolog mode.")))
  (sit-for 1))

  
;; This section defines the selective yank command.
;;
;; This deals with the following situation: when editing long
;; stretches of text, I often want to yank an extent that was killed a
;; while ago. It is annoying to have to type M-y n times for accessing
;; the nth most recent kill. The function selective-yank allows direct
;; selection of the desired kill by (effectively) filtering the kill
;; ring through a user-supplied regexp. If the first matching kill is
;; not the correct one, selective-yank-pop can be used in much the
;; same way as yank-pop after a yank. Both functions are bound to A-y
;; since that is the only reasonable ?-y sequence left, and the
;; decision about which function to call can be resolved by context.

;; It is easiest to use a global variable for this.
(defvar yanked-regexp "REGEXP used by selective-yank.")

;; Another variable so that selective-yank will not actually rotate the
;; kill ring. 
(defvar selective-yank-pointer "Pointer used by selective-yank.")

(defun selective-yank (regexp)
  "Like yank, but only considers killed items matching REGEXP."
  (interactive "*sYank regexp: ")
  (if (null kill-ring)
      (error "Kill ring is empty!")
    (progn 
      (setq this-command 'selective-yank)
      (setq yanked-regexp regexp)
      (setq selective-yank-pointer 0)
      ;; search kill-ring until a match is found
      (let ((item (current-kill 0 t))
            (max (length kill-ring)))
        (while (and
                (<= selective-yank-pointer max)
                (not (string-match regexp item)))
          (incf selective-yank-pointer)
          (setq item (current-kill selective-yank-pointer t)))
        ;; either insert it...
        (if (string-match regexp item)
            (progn 
              (push-mark (point))
              (insert item)
              (exchange-point-and-mark t))
          ;; ...or complain
          (error "No matching kill ring entry!"))))))


(defun selective-yank-pop ()
  "Like yank-pop, but only considers items matching the yanked-regexp."
  ;; since this only called after selective-yank,
  ;; no check for an empty kill ring is necessary...
  (setq this-command 'selective-yank)
  (incf selective-yank-pointer)
  (let* ((max (length kill-ring))
         (item (current-kill (mod selective-yank-pointer max) t)))
    ;; ...nor do we have to check for termination here
    (while (not (string-match yanked-regexp item))
      (setq 
       selective-yank-pointer (mod (1+ selective-yank-pointer) max)
       item (current-kill selective-yank-pointer t)))
    (delete-region (point) (mark t))
    (push-mark)
    (insert item)
    (exchange-point-and-mark t)))
    
;; for testing (setq kill-ring '("one" "two" "three" "four" "five"
;;"six" "seven" "eight" "nine" "ten" "eleven" "twelve"))



;; date computation
(if (try-to-load 'calendar)

    ;; A function for coloring listings of e-commerce transactions.
    (defun mark-overdues () 
      "Scan each line for the date at its beginning, and redden
overdue transactions."
      (interactive)
      (save-excursion
        (goto-char (point-min))
        (let ((this-day (calendar-absolute-from-gregorian
(calendar-current-date))))
          (while (looking-at "(\\([0-9]+\\).\\([0-9]+\\).\\([0-9]+\\))")
            ;; extract date from current line
            (let* ((day (string-to-number (match-string 1)))
                   (month (string-to-number (match-string 2)))
                   (year (string-to-number (match-string 3)))
                   (that-day 
                    (calendar-absolute-from-gregorian (list month day year)))
                   (age (- this-day that-day)))
              ;; An open transaction is one not ending in a date, hence in
              ;; ")"
              (if (looking-at ".*[^)]$")
                  (highlight-regexp 
                   (buffer-substring 
                    (point) (save-excursion (end-of-line) (point)))
                   (reddish-green age)))
              (forward-line 1)
              ))))))
 
(defun reddish-green (n)
  "Return a face composed of N percent red."
  (let* ((f (make-face 
             (make-symbol (format "reddish-green-%d-face" n)) nil 'temporary))
         (red (max 0 (min 255 (round (* (/ n 100.0) 256)))))
         (green (- 255 red))
         (rgb-value (format "#%02X%02X00" red green)))
    (set-face-foreground f rgb-value)
    f))


(defun repeat-last-replace ()
  "Re-evaluate last command that matches `replace'."
  (interactive)
  (let ((history command-history)
	(temp)
	(what))
    (while (and history (not what))
      (setq temp (car history))
      (if (string-match "replace" (symbol-name (car temp)))
	  (setq what (car history))
	(setq history (cdr history))))
    (if (not what)
	(error "Command history exhausted")
      ;; Try to remove any useless command history element for this command.
      (if (eq (car (car command-history)) 'repeat-matching-complex-command)
	  (setq command-history (cdr command-history)))
      (edit-and-eval-command "Redo: " what))))

(defun repeat-last-shell-command ()
  "repeat last command passed to shell-command."
  (interactive)
  (or shell-command-history (error "Nothing to repeat."))
  (shell-command (car shell-command-history)))



;;; configuration of major modes

;; C mode 
(add-hook 'c-mode-hook
	  (function
           (lambda () 
             (define-key c-mode-map [(control c) b] 'c-insert-block)
             (define-key c-mode-map [(control c) c] 'c-insert-comment)
             (define-key c-mode-map [(control c) f] 'c-insert-for)
             (define-key c-mode-map [(control c) i] 'c-insert-if)
             (define-key c-mode-map [(control c) l] 'c-insert-for-list)
             (define-key c-mode-map [(control c) p] 'c-insert-printf)
             (define-key c-mode-map [(control c) s] 'c-insert-switch)
             (define-key c-mode-map [(control c) w] 'c-insert-while)

             (define-key c-mode-map [f8] 'insert-debug-clause)
             (define-key c-mode-map [tab] 'indent-or-expand)
             (define-key c-mode-map [(meta tab)] 'c-indent-command)
             (define-key c-mode-map [(alt tab)] 'indent-relative)
             (define-key c-mode-map [return] 'newline-and-indent)

             ;; This is needed so that function headers in K&R style
             ;; are reported by paren-match.
             (setq paren-backwards-message t)
             (setq fill-column 75)
             (turn-on-auto-fill)

             )))


;; CDG mode 
;; cdg-mode is for editing .cdg files.
;; this file defines cdg mode
;; unpublished, sorry
(load-library "/home/foth/.elisp/cdg.el")

(autoload 'cdg-mode "cdg" "Major mode to edit CDG files." t)

;; In CDG mode, I spend most of my time typing lexical entries.
;; Since CDG mode isn't smart enough to understand their [] nesting,
;; TAB does an indent-relative. Completion is also useful
;; but not as important.
(add-hook 'cdg-mode-hook
	  (function
           (lambda () 
             (define-key cdg-mode-map [tab] 'indent-relative)
             (define-key cdg-mode-map [(meta tab)] 'dabbrev-expand)
             (make-variable-buffer-local 'font-lock-maximum-size)
             (setq font-lock-maximum-size 50000)
             (turn-on-auto-fill)
             (iso-accents-mode)
             )))


;; compilation-mode
(add-hook 'compilation-mode-hook
          (function
           (lambda () (setq truncate-lines nil))))

;; ediff-mode

;; Make ediff use a smaller font and a larger frame than usual
(add-hook 
 'ediff-startup-hook
 (function 
  (lambda () 
    (set-face-font 
     'default 
     ;; Hmmm... how do you say `the current font, but in 12pt' in elisp?
     "-*-Lucidatypewriter-bold-r-*-*-*-120-*-*-*-*-iso8859-*")
    (set-frame-property (selected-frame) 'left 0)
    (set-frame-size (selected-frame) 160 60)
    (raise-frame))))
         
(add-hook
 'ediff-cleanup-hook
 (function
  (lambda ()
    (ediff-janitor)
    (set-face-font
     'default
     "-*-Lucidatypewriter-bold-r-*-*-*-140-*-*-*-*-iso8859-*")
    (set-frame-property (selected-frame) 'left 250)
    (set-frame-size (selected-frame) 90 50))))

             

;; emacs-lisp mode 
(add-hook 'emacs-lisp-mode-hook
	  (function 
           (lambda () 
             (setq paren-backwards-message nil)
             (define-key emacs-lisp-mode-map [tab] 'indent-or-expand)
             (define-key emacs-lisp-mode-map [(shift tab)]
'lisp-complete-symbol)
             (define-key emacs-lisp-mode-map [(alt tab)] 'indent-for-comment)
             (install-lisp-superbracket)
             (turn-on-auto-fill)
             )))

;; Java mode 
(add-hook 'jde-mode-hook
	  (function
           (lambda () 
             (iso-accents-mode)
             (turn-on-auto-fill)
             (setq c-basic-offset 2)
             (define-key java-mode-map [(control c) b] 'c-insert-block)
             (define-key java-mode-map [(control c) c] 'java-insert-comment)
             (define-key java-mode-map [(control c) e] 'c-insert-else)
             (define-key java-mode-map [(control c) f] 'c-insert-for)
             (define-key java-mode-map [(control c) i] 'c-insert-if)
             (define-key java-mode-map [(control c) l] 'c-insert-for-list)
             (define-key java-mode-map [(control c) p] 'jde-gen-println)
             (define-key java-mode-map [(control c) s] 'c-insert-switch)
             (define-key java-mode-map [(control c) w] 'c-insert-while)

             (define-key java-mode-map [f9] 'jde-compile)
             (define-key java-mode-map [f10] 'jde-run)
             (define-key java-mode-map [tab] 'indent-or-expand)
             (define-key java-mode-map [(meta tab)] 'c-indent-command)
             (define-key java-mode-map [return] 'newline-and-indent)
             )))

;; LaTeX mode 
(defalias 'call-TeX
  (read-kbd-macro "<f2> C-c C-c LaTeX RET"))

(defalias 'call-xdvi
  (read-kbd-macro "<f2> C-c C-c View RET"))

(add-hook 
 'LaTeX-mode-hook
 (function 
  (lambda () 

    ;; TeXshell emulation for the function keys
    (define-key LaTeX-mode-map [f6] 'call-TeX)
    (define-key LaTeX-mode-map [f8] 'call-xdvi)
    (define-key LaTeX-mode-map [tab] 'dabbrev-expand)
    (define-key LaTeX-mode-map [(meta tab)] 'indent-according-to-mode)
    (define-key LaTeX-mode-map [(alt tab)] 'indent-relative)
    (define-key LaTeX-mode-map [(control c) (control r)] 'comment-region)
    

    ;; for typing technical documentation with lots of tt in it
    (define-key LaTeX-mode-map [f12] 'verbify)

    (setq TeX-parse-self t)             ; Enable parse on load.
    (setq TeX-auto-save t)              ; Enable parse on save

    )))


;; Makefile mode 
(add-hook 'makefile-mode-hook
          (function
           (lambda () 
             (turn-on-auto-fill)
             )))

;; Perl mode 
(add-hook 'cperl-mode-hook
          (function
           (lambda () 
             (define-key cperl-mode-map [tab] 'indent-or-expand)
             (define-key cperl-mode-map [(alt tab)] 'indent-for-comment)
             (define-key cperl-mode-map [(meta tab)] 'indent-according-to-mode)
             (define-key cperl-mode-map [return] 'newline-and-indent)
             (define-key cperl-mode-map [(control c) b] 'c-insert-block)
             (define-key cperl-mode-map [(control c) f] 'c-insert-for)
             (define-key cperl-mode-map [(control c) i] 'c-insert-if)
             (define-key cperl-mode-map [(control c) w] 'c-insert-while)
             (setq perl-indent-level 2 perl-tab-to-comment t)
             (turn-on-auto-fill)
             (adjust-comment-column)

             ;; prepare new files for a useful life
             (if (= (point-min) (point-max)) 
                 (progn
                   ;; insert boilerplate 
                   (insert-string
                    (concat "#!/opt/bin/perl -w\n"
                            "# " (buffer-file-name) "\n\n"
                            "use strict;\n"))
                   (goto-char (point-max))
                   ;; make executable
                   (save-buffer)
                   (shell-command (format "chmod u+x %s" (buffer-file-name)))
                   )))))

;; Prolog mode 
(add-hook 'prolog-mode-hook
	  (function 
           (lambda () 
             (define-key prolog-mode-map [tab] 'indent-or-expand)
             (define-key prolog-mode-map [(meta tab)]
'indent-according-to-mode)
             (define-key prolog-mode-map [return] 'newline-and-indent)
             (setq comment-start "% ")
             (iso-accents-mode)
             (define-key inferior-prolog-mode-map [up] 
               'comint-previous-matching-input-from-input)
             (define-key inferior-prolog-mode-map [down] 
               'comint-next-matching-input-from-input)
             )))

;; Scheme mode 
(setenv "SCHEME_LIBRARY_PATH" "/usr/local/lib/scm/")
(add-hook 'scheme-mode-hook
	  (function 
           (lambda () 
             (install-lisp-superbracket)

             (define-key scheme-mode-map [tab] 'indent-or-expand)
             (define-key scheme-mode-map [return] 'newline-and-indent)
             (define-key scheme-mode-map [(control c) (control r)] 
               'comment-region)
             (define-key scheme-mode-map ?9 
               (lambda () (interactive) (insert-string "(")))
             (define-key scheme-mode-map ?0 
               (lambda () (interactive) (insert-string ")")))
             (define-key scheme-mode-map ?) 
             (lambda () (interactive) (insert-string "9")))
           (define-key scheme-mode-map ?( 
                                         (lambda () (interactive)
(insert-string "0")))

             (define-key scheme-interaction-mode-map ?9 
               (lambda () (interactive) (insert-string "(")))
             (define-key scheme-interaction-mode-map ?0 
               (lambda () (interactive) (insert-string ")")))
             (define-key scheme-interaction-mode-map ?( 
                                                       (lambda ()
(interactive) (insert-string "9")))
               (define-key scheme-interaction-mode-map ?) 
               (lambda () (interactive) (insert-string "0")))
             (define-key scheme-interaction-mode-map [tab] 'indent-or-expand)
             (define-key scheme-interaction-mode-map [return]
'newline-and-indent)
             (define-key scheme-interaction-mode-map [(control return)] 
               (function
                (lambda () (interactive)
                  (or (bolp) (insert-string "\n"))
                  (advertised-xscheme-send-previous-expression)))))))

;; sh-mode
(add-hook 'sh-mode-hook
	  (function 
           (lambda () 
             (define-key sh-mode-map [tab] 'indent-or-expand)
             )))

;; Tcl mode
(add-hook 'tcl-mode-hook
	  (function 
           (lambda () 
             (define-key tcl-mode-map [(control c) b] 'tcl-insert-block)
             (define-key tcl-mode-map [tab] 'indent-or-expand)
             ;; Tcl mode overwrites M-backspace. We can't have that.
             (define-key tcl-mode-map [(meta backspace)] 'backward-kill-word)
             (setq tcl-indent-level 2)
             (turn-on-auto-fill)
             (filladapt-mode)
             )))

;; Text mode 
(define-key text-mode-map [(meta s)] 'insert-paragraph-glyph)
(define-key text-mode-map [tab] 'dabbrev-expand)
(define-key text-mode-map [(shift tab)] 'lisp-complete-symbol)
(define-key text-mode-map [(control c) s] 'insert-signature)

(add-hook 'text-mode-hook 
          (function
           (lambda ()
             (if (featurep 'filladapt) (filladapt-mode))
             (turn-on-auto-fill)
             (iso-accents-mode))))


;; make <> act as matching parentheses
(defun milc-lists () 
  (modify-syntax-entry ?< "(>")
  (modify-syntax-entry ?> ")<")
  )
(defun no-milc-lists () 
  (modify-syntax-entry ?< ".")
  (modify-syntax-entry ?> ".")
  )

;; function to find out which face is which
(defun describe-face-at-point ()
  "Return face used at point."
  (interactive)
  (let ((face (get-char-property (point) 'face)))
    (if (listp face) 
        (progn
          (message (format "Full value: %s" (prin1-to-string face)))
          (setq face (car face))))
    (hyper-describe-face face)))


;; This section defines the highlight-regexp command.
(defface highlight-regexp-face
  '((t (:foreground "red" :background "white")))
  "face for highlight-regexp.")

(defun highlight-regexp (regexp &optional face property)
  "Highlight all text matching a regexp.

FACE defaults to a combination of red on white. 
All extents created by this function have the property 'highlight.
If non-NIL, PROPERTY is also added to each extent."

  (interactive "sRegexp: ")
  (save-excursion
    (beginning-of-buffer)
    (let ((f face))
      (if (null f) (setq f 'highlight-regexp-face))
      (while (re-search-forward regexp nil t)
        (let ((beg (match-beginning 0))
              (end (match-end 0)))
          (let ((ext (make-extent beg end)))
            (set-extent-property ext 'highlight t)
            (set-extent-face ext f)
            (set-extent-mouse-face ext f)
            (if (not (null property))
                (set-extent-property ext property t))
            ))))))

(defun downlight-regexp (regexp)
  "Remove highlighted extents matching REGEXP."
  (interactive "sRegexp: ")
  (map-extents 
   (lambda (ext maparg) 
     (if (string-match 
          regexp
          (buffer-substring 
           (extent-start-position ext) 
           (extent-end-position ext)))
         (delete-extent ext)))
   (current-buffer) (point-min) (point-max) nil nil 'highlight))

(defun no-highlight () 
  "Remove all extents set by highlight-regexp."
  (interactive) 
  (map-extents 
   (lambda (ext maparg) 
     (delete-extent ext))
   (current-buffer) (point-min) (point-max) nil nil 'highlight))


(defun annotate-N3-programme ()
  "Annotate a Radio3 buffer with fitting glyphs and faces."
  (interactive)
  (save-excursion
    (let ((work-regexp
           (concat 
            "\\([^/:0-9]\\|[0-9]+\\.\\)"
            "[^/:]+"
            "\\("
            "[KRW]V\\|"                 ; Bach, Sch&uuml;tz, etc.
            "D [0-9]+\\|"               ; Schubert
            "Wq [0-9]+\\|"              ; C.P.E. Bach
            "Hob\\. [ IVX:0-9b]+\\|"    ; Haydn
            "-dur\\|-moll\\|"           ; tonal music
            "Nr\\.\\|"                  ; generic
            "op\\.\\|"                  ; generic
            "\\baus \\|"                ; excerpts
            "``[^']''"                  ; titles
            "\\)" 
            "[^:/\n]*"
            ))
          (composer-regexp 
           "[^:0-9\n]\\([-./ ]\\|\\sw\\)+[^:0-9A-Z\n ]:\\s "))

      ;; make all time expressions flush left
      (replace-regexp "^\\s *\\([0-9][0-9]:[0-9][0-9]\\)\\s *" "\\1	")

      ;; recode pdf characters
      (format-replace-strings
       '(("‚" . "`")
         ("‘" . "'")
         ("’" . "'")
         ("“" . "``")
         ("”" . "''")
         ("–" . "---")
         ("š" . "s")
         ("ž" . "?")                    ; what the $%!*&# is this character?
         ("œ" . "oe")))

      ;; for some reason they keep misspelling those names...
      (mapcar
       (function (lambda (arg)
                   (goto-char (point-min))
                   (while (search-forward (car arg) nil t)
                     (replace-match (cdr arg) nil t))))
       '(
         ("Dvoøák" . "Dvorák")
         ("Janáèek" . "Janacek")
         ("Jiøi" . "Jiri")
         ("Saint-Sa¸ns" . "Saint-Saëns")
         ))
      ;; ...or perhaps it's just a bug in SOffice's pdf rendering.

      (setq case-fold-search nil)
      
      ;; highlight composers
      (highlight-regexp composer-regexp 'red 'composer)
      ;; erase some false positives
      (downlight-regexp "Moderation")
      (downlight-regexp "Vorgesehen")
      (downlight-regexp "Am Mikrofon")
      (downlight-regexp "Solist")
      (downlight-regexp "Nachrichten")
      (downlight-regexp "Ltg")
      (downlight-regexp "Leitung")
 
      ;; Work titles are impossible to catch by regexp.
      ;; Here we just highlight everything after a composer,
      ;; up to the next / or line break.
      (setq i 0)
      (map-extents 
       (lambda (extent maparg) 
         (goto-char (extent-end-position extent))
         (while (looking-at "\n") (forward-char))
         (let ((extent (make-extent (point)
                                    (save-excursion 
                                      (re-search-forward "/\\|\n" nil t)
                                      (match-beginning 0)))))
           (set-extent-property extent 'highlight t)
           (set-extent-property extent 'title t)
           (set-extent-mouse-face extent 'blue)
           (set-extent-face extent 'blue))
         nil
         ) nil nil nil nil nil 'composer)

      ;; Only a few work titles can be recognized directly.
      (highlight-regexp work-regexp 'blue 'title)

      ;; Include a local variables section to auto-highlight this file
      ;; in the future.
      (if (not (string-match "Local Variables:" (buffer-string)))
          (progn
            (goto-char (point-max))
            (insert-string (concat 
                            "\n"
                            "Local Variables:\n" 
                            "eval:(annotate-N3-programme)\n"
                            "End: ***\n"))))
 
      ))
  (save-buffer))

  
(defun libcdg-sort-functions ()
  "Sort the subsubsections of the current module in libcdg.tex alphabetically."
  (interactive)
  ;; mark the current section
  (let ((min (save-excursion
               (or (re-search-backward "\\\\module{" nil t)
                   (error "Not outside a module."))
               (re-search-forward "\\\\subsection{Algorithms" nil t)
               (forward-line 1)
               (point)))
        (max (save-excursion
               (re-search-forward "\\(\\\\module{\\)\\|\\(\\\\end{document\\)" nil t)
               (match-beginning 0)))
        (pivot "\\\\function"))

    (save-excursion
      (save-restriction
        (narrow-to-region min max)
        ;; mark all \function declarations
        (goto-char (point-min))
        (replace-regexp (concat "\\(" pivot "\\)") "###\\1")

        ;; sort all ###\function records alphabetically
        (goto-char (point-min))
        (sort-regexp-fields nil "###\\([^#]\\|\\n\\)+""\\&" (point-min) (point-max))
        (goto-char (point-min))
        ;; remove markers
        (replace-regexp "###" "")
        ))
    )
  )
  

(defun find-all-files (regexp)
  "Find multiple files in one command."
  (interactive "sFind files matching regexp (default all): ")
  (if (string= "" regexp) (setq regexp ""))
  (let ((dir (file-name-directory regexp))
        (nodir (file-name-nondirectory regexp)))
    (if dir (cd dir))
    (if (string= "" nodir) (setq nodir "."))
    (let ((files (directory-files "." t nodir nil t))
          (errors 0))
      (while (not (null files))
        (let ((filename (car files)))
          (if (file-readable-p filename)
              (find-file-noselect filename)
            (incf errors))
          (setq files (cdr files))))
      (if (> errors 0)
          (message (format "%d files were unreadable." errors))))))
        
;; guess the file-local value of comment-column
(defun adjust-comment-column ()
  "Set comment-column according to the comments in this file."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (re-search-forward ";\\s +#" nil t)
    (setq comment-column (- (current-column) 1))))


;; indent to the same column as the last line longer than this does.
;; This sounds complicated, but it is in fact much more useful than
;; what the normal indent-relative does.
(defun my-indent-relative () 
  "Indent to tab stop guessed from some previous line."
  (interactive)
  (end-of-line)
  (and 
   (save-excursion
     (re-search-backward 
      (format "^.\\{%s\\}[^\n ]* +[^ ]" (current-column)) nil t))
   (message (format "Model: \'%s\'" (match-string 0)))
   (insert (make-string
            (- (length (match-string 0)) (current-column) 1)
            ? ))))


(defun insert-signature (regexp) 
  "Insert signature specified by REGEXP."
  (interactive "*sSignature key: ")
  ;; don't pollute the global kill-ring
  (let ((kill-ring))
    (save-excursion
      (goto-char (point-max))
      (insert "\n-- \n")
      (save-excursion
        (set-buffer (find-file-noselect "~/.signatures"))
        (setq kill-ring
              (append (split-string (buffer-string) "\n-- \n") kill-ring)))
      (selective-yank regexp)))
  (save-buffer))

(defun c-instrument-function (&optional sparse) 
  "Insert lots of printf statements into C code."
  (interactive "*P")
  (save-excursion
    (c-mark-function)
    (save-restriction
      (narrow-to-region (region-beginning) (region-end))
      (goto-char (point-min))
      (re-search-forward "\\([^ ]+\\)\\s *(")
      (let ((i 0) 
            (proc (match-string 1))
            (marker " /* DELETE ME! */\n")
            )
        (if (null sparse)
            (while (re-search-forward "^\\s *\n" nil t)
              (incf i)
              (insert-string 
               (format "printf (\"%s: checkpoint %d...\\n\");%s" proc i marker))))

        ))))


(defun tcl-instrument-function (&optional sparse) 
  "Insert lots of puts statements into Tcl code."
  (interactive "*P")
  (save-excursion
    (tcl-mark-defun)
    (save-restriction
      (narrow-to-region (region-beginning) (region-end))
      (goto-char (point-min))
      (re-search-forward 
       (concat
        "^\\s *"
        "\\(proc\\|body\\)\\s +"
        "\\([^{ ]+\\)\\s *{"
        "\\([^}]*\\)}"))
      (let ((i 0) 
            (proc (match-string 2))
            (args (match-string 3))
            (marker " ;# DELETE ME!\n")
            )
        (setq args (replace-in-string args "\\(^\\|\\s \\)\\([^$ ]\\)" "\\1\\$\\2"))
        (forward-line)
        (insert-string (concat "puts \"" proc "{" args "}: entering...\"" marker))
        (if (null sparse)
            (while (re-search-forward "^\\s *\n" nil t)
              (incf i)
              (insert-string 
               (format "puts \"%s: checkpoint %d...\"%s" proc i marker))))
        (goto-char (point-max))
        (re-search-backward "}")
        (insert-string (concat "puts \"" proc "{" args "}: exiting...\"" marker))
        ))))

(defun tcl-instrument-file (&optional sparse)
  "Call tcl-instrument-function on each function in the file."
  (interactive "P")
  (save-excursion
    (goto-char (point-min))
    (while (re-search-forward 
            "^\\s *\\(proc\\|body\\)\\s +\\([^{]+\\){" nil t)
      (forward-line)
      (tcl-instrument-function sparse))))


(defun remove-checkpoints ()
  "Remove lines inserted by tcl-instrument-function."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (flush-lines "DELETE ME!")))


(defun quoted-insert-file (name delim)
  "Insert contents of a file with a delimiter, as in mail."
  (interactive "*fInsert file: \nsDelimiter (default \"> \"):")
  (if (string= "" delim) (setq delim "> "))
  (insert-file name)
  (replace-regexp "^" delim))


(defun split-quoted-line ()
  "Prepare an insertion within a line of quoted text."
  (interactive)
  (let ((goal-column (current-column))
        ;; this should be computed with (fill-context-prefix) 
        (fill-prefix " > "))            
    (insert "\n")
    (insert fill-prefix)
    (indent-to-column goal-column)))
    


;; Make *scratch* unkillable
(save-excursion
  (set-buffer (get-buffer-create "*scratch*"))
  (lisp-interaction-mode)
  (make-local-variable 'kill-buffer-query-functions)
  (add-hook 'kill-buffer-query-functions 'kill-scratch-buffer))

(defun kill-scratch-buffer ()
  ;; Kill the current (*scratch*) buffer
  (remove-hook 'kill-buffer-query-functions 'kill-scratch-buffer)
  (kill-buffer (current-buffer))

  ;; Make a brand new *scratch* buffer
  (set-buffer (get-buffer-create "*scratch*"))
  (lisp-interaction-mode)
  (make-local-variable 'kill-buffer-query-functions)
  (add-hook 'kill-buffer-query-functions 'kill-scratch-buffer)

  ;; Since we killed it, don't let caller do that.
  nil)

;;; advice to external functions

(defadvice xscheme-default-command-line (after myfix activate)
  "Fix erroneous assumption that all schemes grok -emacs."
  (setq ad-return-value (replace-in-string ad-return-value "-emacs" "")))
(ad-activate 'xscheme-default-command-line)
              

;; Many preloaded functions think that their source is found in
;; /home/siemonsen/download/xemacs-21.1.6, 'cos that's where Kai
;; preloaded them. Utter nonsense, of course. That dir doesn't even
;; exist anymore. But this stupid notion does prevent them from
;; displaying properly under find-function. This piece of advice makes
;; the central find routine ignore all path info. Could be a problem
;; if different packages used the same file names, but I've never seen
;; it happen.
(defadvice find-function-search-for-symbol (before basename activate)
  "Strip possibly incorrect path info from library files' names."
  (setq library (file-name-nondirectory library)))
(ad-activate 'find-function-search-for-symbol)


;;; customization is in a separate file
(load (setq custom-file "~/.elisp/custom"))

;;; Fix things screwed up by customization

(setq minibuffer-max-depth nil)

;; My customization disables display of time & system load in the
;; modeline. In fact, I only want the mail icon. But that package does
;; not react asynchronously to changes to its variables. You actually
;; have to re-execute display-time for the changes to have effect.
(display-time)

;; Hunt for user-defined C types in the tag files. This must happen
;; here because customization turns off the requester about building
;; the tags table; if I called this before applying customization, I
;; would have to type 'y' during startup.
(if (featurep 'ctypes)
    (ctypes-tags))


;; using emacs as root is kind of dangerous, 
;; so make sure I never forget it
(if (= 0 (user-uid))
    (progn 

      ;; make text appear white on black
      (set-face-foreground 'default "white")
      (set-face-background 'default "black")

      ;; Of course, this makes some things invisible that used to have
      ;; dark foregrounds. So we change those as well.
      (set-face-background 'text-cursor "red")

      (set-face-foreground 'paren-match "white")
      (set-face-background 'paren-match "grey50")

      (set-face-foreground 'highlight "black")
      (set-face-background 'highlight "white")
      (if (featurep 'xemacs) 
          (progn 
            (set-face-foreground 'font-lock-keyword-face "yellow")
            (set-face-foreground 'font-lock-comment-face "red")
            (set-face-foreground 'font-lock-type-face  "dodgerblue")
            (set-face-foreground 'font-lock-function-name-face "dodgerblue")
            (set-face-foreground 'font-lock-variable-name-face "dodgerblue"))

        ;; make backups in the cwd
        (setq bkup-backup-directory-info (quote (("^" "." ok-create))))

        (set-background-color "black"))))
;; All this could be done by using specifiers, but that will have to
;; wait until I have a lot of time.