ocamltags.in

":" ; @EMACS@ -batch -l $0 "$@" ; status=$? ; : '--*-Emacs-Lisp-*--' <<';'

;**************************************************************************
;*                                                                        *
;*                                 OCaml                                  *
;*                                                                        *
;*                 Jacques Garrigue and Ian T Zimmerman                   *
;*                                                                        *
;*   Copyright 1998 Institut National de Recherche en Informatique et     *
;*     en Automatique.                                                    *
;*                                                                        *
;*   All rights reserved.  This file is distributed under the terms of    *
;*   the GNU General Public License.                                      *
;*                                                                        *
;**************************************************************************

;; Copyright (C) 1998 Ian Zimmerman <itz@transbay.net>
;;  This program is free software; you can redistribute it and/or
;;  modify it under the terms of the GNU General Public License as
;;  published by the Free Software Foundation; either version 2 of the
;;  License, or (at your option) any later version.

;;  This program is distributed in the hope that it will be useful,
;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;  General Public License for more details.

(require 'caml)

;;itz Fri Oct 30 13:08:37 PST 1998 support for creating TAGS files
;; itz Sun Dec 27 10:26:08 PST 1998 adapted very slightly from
;; Jacques' caml-create-index-function
(defun caml-tags-create-index-function ()
  (let (all-alist index)
    (goto-char (point-max))
    ;; collect definitions
    (while (caml-prev-index-position-function)
      (if (looking-at "[ \t]*val") nil
        (setq index (cons (caml-match-string 5) (point)))
        (setq all-alist (cons index all-alist))))
    all-alist))

(defun caml-tags-file (filename)
  (let* ((output-buffer (current-buffer))
         (basename (file-name-nondirectory filename))
         (backpatch (prog2
                        (insert "\n" basename)
                        (point))))
    (find-file-read-only filename)
    (caml-mode)
    (let ((all-alist (caml-tags-create-index-function))
          (done nil)
          (current-line 1)
          (last-point (point-min)))
      (mapcar
       (lambda (pair)
         (let ((tag-name (car pair)) (tag-pos (cdr pair)))
           (goto-char tag-pos)
           (setq current-line
                 (+ current-line (count-lines last-point (point))))
           (setq last-point (point))
           (end-of-line 1)
           (let ((output-line (format "%s%s
%d,%d\n"
                                      (buffer-substring last-point (point))
                                      tag-name current-line tag-pos)))
             (save-excursion
               (set-buffer output-buffer)
               (insert output-line)))))
       all-alist))
    (kill-buffer (current-buffer))
    (set-buffer output-buffer)
    (let ((index-size (- (point) backpatch)))
      (goto-char backpatch)
      (insert "," (int-to-string index-size) "\n")
      (goto-char (point-max)))))

(defsubst prefix-p (prefix str)
  (and (<= (length prefix) (length str))
       (string= prefix (substring str 0 (length prefix)))))

(defsubst eat-args (n)
  (setq command-line-args-left (nthcdr n command-line-args-left)))

;; see Emacs source file print.c
(defun print-error-message (data)
  (let ((errname (car data)) errmsg is-file-error tail i)
    (if (eq errname 'error)
        (progn
          (setq data (cdr data))
          (if (not (consp data)) (setq data nil))
          (setq errmsg (car data))
          (setq is-file-error nil))
      (setq errmsg (get errname 'error-message))
      (setq is-file-error (memq 'file-error (get errname 'error-conditions))))
    (setq tail (cdr-safe data))
    (if (and is-file-error tail)
        (setq errmsg (car tail) tail (cdr tail)))
    (if (stringp errmsg) (princ errmsg)
      (princ "peculiar error"))
    (setq i 0)
    (while (consp tail)
      (princ (if (eq i 0) ": " ", "))
      (if is-file-error (princ (car tail))
        (prin1 (car tail)))
      (setq tail (cdr tail) i (1+ i)))
    (princ "\n")))


(setq gc-cons-threshold 1000000)

(setq output-file "TAGS")
(setq append-flag nil)
(setq status 0)

(condition-case foobar
    (progn
      (while (and command-line-args-left
                  (let ((arg (car command-line-args-left)))
                    (cond
                     ((prefix-p arg "-output-file")
                      (setq output-file (nth 1 command-line-args-left))
                      (eat-args 2) t)
                     ((prefix-p arg "-append")
                      (setq append-flag t)
                      (eat-args 1) t)
                     (t nil)))))

      (find-file output-file)
      (if append-flag (goto-char (point-max))
        (erase-buffer))
      (while command-line-args-left
        (caml-tags-file (car command-line-args-left))
        (setq command-line-args-left (cdr command-line-args-left)))
      (save-buffer 0))
  (error (setq status 1) (print-error-message foobar)))

(kill-emacs status)

;

":" ; exit $status