guile18/emacs/guile-c.el

   1 ;;; guile-c.el --- Guile C editing commands
   2
   3 ;; Copyright (C) 2001, 2006 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., 51 Franklin Street, Fifth Floor,
  18 ;; Boston, MA 02110-1301, 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-p" 'guile-c-insert-define)
  26 ;;     (define-key c-mode-map "\C-c\C-g\C-e" 'guile-c-edit-docstring)
  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 (defvar guile-c-window-configuration nil)
 102
 103 (defun guile-c-edit-docstring ()
 104   (interactive)
 105   (let* ((region (guile-c-find-docstring))
 106          (doc (if region (buffer-substring (car region) (cdr region)))))
 107     (if (not doc)
 108         (error "No docstring!")
 109       (setq guile-c-window-configuration (current-window-configuration))
 110       (with-current-buffer (get-buffer-create "*Guile Docstring*")
 111         (erase-buffer)
 112         (insert doc)
 113         (goto-char (point-min))
 114         (while (not (eobp))
 115           (if (looking-at "[ \t]*\"")
 116               (delete-region (match-beginning 0) (match-end 0)))
 117           (end-of-line)
 118           (if (eq (char-before (point)) ?\")
 119               (delete-backward-char 1))
 120           (if (and (eq (char-before (point)) ?n)
 121                    (eq (char-before (1- (point))) ?\\))
 122               (delete-backward-char 2))
 123           (forward-line))
 124         (goto-char (point-min))
 125         (texinfo-mode)
 126         (if global-font-lock-mode
 127             (font-lock-fontify-buffer))
 128         (local-set-key "\C-c\C-c" 'guile-c-edit-finish)
 129         (setq fill-column 63)
 130         (switch-to-buffer-other-window (current-buffer))
 131         (message "Type `C-c C-c' to finish")))))
 132
 133 (defun guile-c-edit-finish ()
 134   (interactive)
 135   (goto-char (point-max))
 136   (while (eq (char-before) ?\n) (backward-delete-char 1))
 137   (goto-char (point-min))
 138   (if (eobp)
 139       (insert "\"\"")
 140     (while (not (eobp))
 141       (insert "\t    \"")
 142       (end-of-line)
 143       (insert (if (eobp) "\"" "\\n\""))
 144       (forward-line 1)))
 145   (let ((doc (buffer-string)))
 146     (kill-buffer (current-buffer))
 147     (set-window-configuration guile-c-window-configuration)
 148     (let ((region (guile-c-find-docstring)))
 149       (goto-char (car region))
 150       (delete-region (car region) (cdr region)))
 151     (insert doc)))
 152
 153 (defun guile-c-find-docstring ()
 154   (save-excursion
 155     (if (re-search-backward "^SCM_DEFINE" nil t)
 156         (let ((start (progn (forward-line 2) (point))))
 157           (while (looking-at "[ \t]*\"")
 158             (forward-line 1))
 159           (cons start (- (point) 2))))))
 160
 161 \f
 162 ;;;
 163 ;;; Others
 164 ;;;
 165
 166 (defun guile-c-deprecate-region (start end)
 167   (interactive "r")
 168   (save-excursion
 169     (let ((marker (make-marker)))
 170       (set-marker marker end)
 171       (goto-char start)
 172       (insert "#if (SCM_DEBUG_DEPRECATED == 0)\n\n")
 173       (goto-char marker)
 174       (insert "\n#endif /* (SCM_DEBUG_DEPRECATED == 0) */\n"))))
 175
 176 (provide 'guile-c)
 177
 178 ;; guile-c.el ends here