cgit.sxemacs.org Git - packages/blob - xemacs-packages/ocaml/ocamltags.in

   1 ":" ; @EMACS@ -batch -l $0 "$@" ; status=$? ; : '--*-Emacs-Lisp-*--' <<';'
   2
   3 ;; Copyright (C) 1998 Ian Zimmerman <itz@transbay.net>
   4 ;;  This program is free software; you can redistribute it and/or
   5 ;;  modify it under the terms of the GNU General Public License as
   6 ;;  published by the Free Software Foundation; either version 2 of the
   7 ;;  License, or (at your option) any later version.
   8
   9 ;;  This program is distributed in the hope that it will be useful,
  10 ;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;  General Public License for more details.
  13 ;; $Id: ocamltags.in,v 1.5 1999/11/29 19:03:30 doligez Exp $
  14
  15 (require 'caml)
  16
  17 ;;itz Fri Oct 30 13:08:37 PST 1998 support for creating TAGS files
  18 ;; itz Sun Dec 27 10:26:08 PST 1998 adapted very slightly from
  19 ;; Jacques' caml-create-index-function
  20 (defun caml-tags-create-index-function ()
  21   (let (all-alist index)
  22     (goto-char (point-max))
  23     ;; collect definitions
  24     (while (caml-prev-index-position-function)
  25       (if (looking-at "[ \t]*val") nil
  26         (setq index (cons (caml-match-string 5) (point)))
  27         (setq all-alist (cons index all-alist))))
  28     all-alist))
  29
  30 (defun caml-tags-file (filename)
  31   (let* ((output-buffer (current-buffer))
  32          (basename (file-name-nondirectory filename))
  33          (backpatch (prog2
  34                         (insert "\f\n" basename)
  35                         (point))))
  36     (find-file-read-only filename)
  37     (caml-mode)
  38     (let ((all-alist (caml-tags-create-index-function))
  39           (done nil)
  40           (current-line 1)
  41           (last-point (point-min)))
  42       (mapcar
  43        (lambda (pair)
  44          (let ((tag-name (car pair)) (tag-pos (cdr pair)))
  45            (goto-char tag-pos)
  46            (setq current-line
  47                  (+ current-line (count-lines last-point (point))))
  48            (setq last-point (point))
  49            (end-of-line 1)
  50            (let ((output-line (format "%s\7f%s\ 1%d,%d\n"
  51                                       (buffer-substring last-point (point))
  52                                       tag-name current-line tag-pos)))
  53              (save-excursion
  54                (set-buffer output-buffer)
  55                (insert output-line)))))
  56        all-alist))
  57     (kill-buffer (current-buffer))
  58     (set-buffer output-buffer)
  59     (let ((index-size (- (point) backpatch)))
  60       (goto-char backpatch)
  61       (insert "," (int-to-string index-size) "\n")
  62       (goto-char (point-max)))))
  63
  64 (defsubst prefix-p (prefix str)
  65   (and (<= (length prefix) (length str))
  66        (string= prefix (substring str 0 (length prefix)))))
  67
  68 (defsubst eat-args (n)
  69   (setq command-line-args-left (nthcdr n command-line-args-left)))
  70
  71 ;; see Emacs source file print.c
  72 (defun print-error-message (data)
  73   (let ((errname (car data)) errmsg is-file-error tail i)
  74     (if (eq errname 'error)
  75         (progn
  76           (setq data (cdr data))
  77           (if (not (consp data)) (setq data nil))
  78           (setq errmsg (car data))
  79           (setq is-file-error nil))
  80       (setq errmsg (get errname 'error-message))
  81       (setq is-file-error (memq 'file-error (get errname 'error-conditions))))
  82     (setq tail (cdr-safe data))
  83     (if (and is-file-error tail)
  84         (setq errmsg (car tail) tail (cdr tail)))
  85     (if (stringp errmsg) (princ errmsg)
  86       (princ "peculiar error"))
  87     (setq i 0)
  88     (while (consp tail)
  89       (princ (if (eq i 0) ": " ", "))
  90       (if is-file-error (princ (car tail))
  91         (prin1 (car tail)))
  92       (setq tail (cdr tail) i (1+ i)))
  93     (princ "\n")))
  94
  95
  96 (setq gc-cons-threshold 1000000)
  97
  98 (setq output-file "TAGS")
  99 (setq append-flag nil)
 100 (setq status 0)
 101
 102 (condition-case foobar
 103     (progn
 104       (while (and command-line-args-left
 105                   (let ((arg (car command-line-args-left)))
 106                     (cond
 107                      ((prefix-p arg "-output-file")
 108                       (setq output-file (nth 1 command-line-args-left))
 109                       (eat-args 2) t)
 110                      ((prefix-p arg "-append")
 111                       (setq append-flag t)
 112                       (eat-args 1) t)
 113                      (t nil)))))
 114
 115       (find-file output-file)
 116       (if append-flag (goto-char (point-max))
 117         (erase-buffer))
 118       (while command-line-args-left
 119         (caml-tags-file (car command-line-args-left))
 120         (setq command-line-args-left (cdr command-line-args-left)))
 121       (save-buffer 0))
 122   (error (setq status 1) (print-error-message foobar)))
 123
 124 (kill-emacs status)
 125
 126 ;
 127
 128 ":" ; exit $status