emacs/guile-c.el

   1 ;;; guile-c.el --- Guile C editing commands
   2
   3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to the
  17 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Commentary:
  21
  22 ;; (add-hook 'c-mode-hook
  23 ;;   (lambda ()
  24 ;;     (require 'guile-c)
  25 ;;     (define-key c-mode-map "\C-c\C-g\C-e" 'guile-c-edit-docstring)
  26 ;;     (define-key c-mode-map "\C-c\C-g\C-p" 'guile-c-insert-define)
  27 ;;     (define-key c-mode-map "\C-c\C-g\C-d" 'guile-c-deprecate-region)
  28 ;;     ))
  29
  30 ;;; Code:
  31
  32 (require 'cc-mode)
  33
  34 (defvar guile-c-prefix "scm_")
  35
  36 \f
  37 ;;;
  38 ;;; Insert templates
  39 ;;;
  40
  41 (defun guile-c-insert-define ()
  42   "Insert a template of a Scheme procedure.
  43
  44   M-x guile-c-insert-define RET foo arg , opt . rest =>
  45
  46   SCM_DEFINE (scm_foo, \"foo\", 1, 1, 1,
  47               (SCM arg, SCM opt, SCM rest),
  48               \"\")
  49   #define FUNC_NAME s_scm_foo
  50   {
  51
  52   }
  53   #undef FUNC_NAME"
  54   (interactive)
  55   (let ((tokens (split-string (read-string "Procedure: ")))
  56         name args opts rest)
  57     ;; Get procedure name
  58     (if (not tokens) (error "No procedure name"))
  59     (setq name (car tokens) tokens (cdr tokens))
  60     ;; Get requisite arguments
  61     (while (and tokens (not (member (car tokens) '("," "."))))
  62       (setq args (cons (car tokens) args) tokens (cdr tokens)))
  63     (setq args (nreverse args))
  64     ;; Get optional arguments
  65     (when (string= (car tokens) ",")
  66       (setq tokens (cdr tokens))
  67       (while (and tokens (not (string= (car tokens) ".")))
  68         (setq opts (cons (car tokens) opts) tokens (cdr tokens)))
  69       (setq opts (nreverse opts)))
  70     ;; Get rest argument
  71     (when (string= (car tokens) ".")
  72       (setq rest (list (cadr tokens))))
  73     ;; Insert template
  74     (let ((c-name (guile-c-name-from-scheme-name name)))
  75       (insert (format "SCM_DEFINE (%s, \"%s\", %d, %d, %d,\n"
  76                       c-name name (length args) (length opts) (length rest))
  77               "\t    ("
  78               (mapconcat (lambda (a) (concat "SCM " a))
  79                          (append args opts rest) ", ")
  80               "),\n"
  81               "\t    \"\")\n"
  82               "#define FUNC_NAME s_" c-name "\n"
  83               "{\n\n}\n"
  84               "#undef FUNC_NAME\n\n")
  85       (previous-line 4)
  86       (indent-for-tab-command))))
  87
  88 (defun guile-c-name-from-scheme-name (name)
  89   (while (string-match "\\?$" name) (setq name (replace-match "_p" t t name)))
  90   (while (string-match "!$" name) (setq name (replace-match "_x" t t name)))
  91   (while (string-match "^%" name) (setq name (replace-match "sys_" t t name)))
  92   (while (string-match "->" name) (setq name (replace-match "_to_" t t name)))
  93   (while (string-match "[-:]" name) (setq name (replace-match "_" t t name)))
  94   (concat guile-c-prefix name))
  95
  96 \f
  97 ;;;
  98 ;;; Edit docstrings
  99 ;;;
 100
 101 (defun guile-c-edit-docstring ()
 102   (interactive)
 103   (let* ((region (guile-c-find-docstring))
 104          (doc (if region (buffer-substring (car region) (cdr region)))))
 105     (if (not doc)
 106         (error "No docstring!")
 107       (with-current-buffer (get-buffer-create "*Guile Docstring*")
 108         (erase-buffer)
 109         (insert doc)
 110         (goto-char (point-min))
 111         (while (not (eobp))
 112           (if (looking-at "[ \t]*\"")
 113               (delete-region (match-beginning 0) (match-end 0)))
 114           (end-of-line)
 115           (if (eq (char-before (point)) ?\")
 116               (delete-backward-char 1))
 117           (if (and (eq (char-before (point)) ?n)
 118                    (eq (char-before (1- (point))) ?\\))
 119               (delete-backward-char 2))
 120           (forward-line))
 121         (goto-char (point-min))
 122         (texinfo-mode)
 123         (if global-font-lock-mode
 124             (font-lock-fontify-buffer))
 125         (local-set-key "\C-c\C-c" 'guile-c-edit-finish)
 126         (switch-to-buffer-other-window (current-buffer))
 127         (message "Type `C-c C-c' to finish")))))
 128
 129 (defun guile-c-edit-finish ()
 130   (interactive)
 131   (goto-char (point-max))
 132   (while (eq (char-before) ?\n) (backward-delete-char 1))
 133   (goto-char (point-min))
 134   (if (eobp)
 135       (insert "\"\"")
 136     (while (not (eobp))
 137       (insert "\t    \"")
 138       (end-of-line)
 139       (insert (if (eobp) "\"" "\\n\""))
 140       (forward-line 1)))
 141   (let ((doc (buffer-string)))
 142     (kill-buffer (current-buffer))
 143     (delete-window (selected-window))
 144     (let ((region (guile-c-find-docstring)))
 145       (goto-char (car region))
 146       (delete-region (car region) (cdr region)))
 147     (insert doc)))
 148
 149 (defun guile-c-find-docstring ()
 150   (save-excursion
 151     (if (re-search-backward "^SCM_DEFINE" nil t)
 152         (let ((start (progn (forward-line 2) (point))))
 153           (while (looking-at "[ \t]*\"")
 154             (forward-line 1))
 155           (cons start (- (point) 2))))))
 156
 157 \f
 158 ;;;
 159 ;;; Others
 160 ;;;
 161
 162 (defun guile-c-deprecate-region (start end)
 163   (interactive "r")
 164   (save-excursion
 165     (let ((marker (make-marker)))
 166       (set-marker marker end)
 167       (goto-char start)
 168       (insert "#if (SCM_DEBUG_DEPRECATED == 0)\n\n")
 169       (goto-char marker)
 170       (insert "\n#endif /* (SCM_DEBUG_DEPRECATED == 0) */\n"))))
 171
 172 (provide 'guile-c)
 173
 174 ;; guile-c.el ends here