emacs/guile-c.el

   1 ;;; guile-c.el --- Guile C editing commands
   2
   3 ;; Copyright (C) 2001 Keisuke Nishida <kxn30@po.cwru.edu>
   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 ;;     ))
  28
  29 ;;; Code:
  30
  31 (require 'cc-mode)
  32
  33 (defvar guile-c-prefix "scm_")
  34
  35 ;;;
  36 ;;; Insert templates
  37 ;;;
  38
  39 (defun guile-c-insert-define ()
  40   "Insert a template of a Scheme procedure.
  41
  42   M-x guile-c-insert-define RET foo arg , opt . rest =>
  43
  44   SCM_DEFINE (scm_foo, \"foo\", 1, 1, 1,
  45               (SCM arg, SCM opt, SCM rest),
  46               \"\")
  47   #define FUNC_NAME s_scm_foo
  48   {
  49
  50   }
  51   #undef FUNC_NAME"
  52   (interactive)
  53   (let ((tokens (split-string (read-string "Procedure: ")))
  54         name args opts rest)
  55     ;; Get procedure name
  56     (if (not tokens) (error "No procedure name"))
  57     (setq name (car tokens) tokens (cdr tokens))
  58     ;; Get requisite arguments
  59     (while (and tokens (not (member (car tokens) '("," "."))))
  60       (setq args (cons (car tokens) args) tokens (cdr tokens)))
  61     (setq args (nreverse args))
  62     ;; Get optional arguments
  63     (when (string= (car tokens) ",")
  64       (setq tokens (cdr tokens))
  65       (while (and tokens (not (string= (car tokens) ".")))
  66         (setq opts (cons (car tokens) opts) tokens (cdr tokens)))
  67       (setq opts (nreverse opts)))
  68     ;; Get rest argument
  69     (when (string= (car tokens) ".")
  70       (setq rest (list (cadr tokens))))
  71     ;; Insert template
  72     (let ((c-name (guile-c-name-from-scheme-name name)))
  73       (insert (format "SCM_DEFINE (%s, \"%s\", %d, %d, %d,\n"
  74                       c-name name (length args) (length opts) (length rest))
  75               "\t    ("
  76               (mapconcat (lambda (a) (concat "SCM " a))
  77                          (append args opts rest) ", ")
  78               "),\n"
  79               "\t    \"\")\n"
  80               "#define FUNC_NAME s_" c-name "\n"
  81               "{\n\n}\n"
  82               "#undef FUNC_NAME\n\n")
  83       (previous-line 4)
  84       (indent-for-tab-command))))
  85
  86 (defun guile-c-name-from-scheme-name (name)
  87   (while (string-match "\\?$" name) (setq name (replace-match "_p" t t name)))
  88   (while (string-match "!$" name) (setq name (replace-match "_x" t t name)))
  89   (while (string-match "^%" name) (setq name (replace-match "sys_" t t name)))
  90   (while (string-match "->" name) (setq name (replace-match "_to_" t t name)))
  91   (while (string-match "[-:]" name) (setq name (replace-match "_" t t name)))
  92   (concat guile-c-prefix name))
  93
  94 ;;;
  95 ;;; Edit docstrings
  96 ;;;
  97
  98 (defun guile-c-edit-docstring ()
  99   (interactive)
 100   (let* ((region (guile-c-find-docstring))
 101          (doc (if region (buffer-substring (car region) (cdr region)))))
 102     (if (not doc)
 103         (error "No docstring!")
 104       (with-current-buffer (get-buffer-create "*Guile Docstring*")
 105         (erase-buffer)
 106         (insert doc)
 107         (goto-char (point-min))
 108         (while (not (eobp))
 109           (if (looking-at "[ \t]*\"")
 110               (delete-region (match-beginning 0) (match-end 0)))
 111           (end-of-line)
 112           (if (eq (char-before (point)) ?\")
 113               (delete-backward-char 1))
 114           (if (and (eq (char-before (point)) ?n)
 115                    (eq (char-before (1- (point))) ?\\))
 116               (delete-backward-char 2))
 117           (forward-line))
 118         (goto-char (point-min))
 119         (texinfo-mode)
 120         (if global-font-lock-mode
 121             (font-lock-fontify-buffer))
 122         (local-set-key "\C-c\C-c" 'guile-c-edit-finish)
 123         (switch-to-buffer-other-window (current-buffer))
 124         (message "Type `C-c C-c' to finish")))))
 125
 126 (defun guile-c-edit-finish ()
 127   (interactive)
 128   (goto-char (point-max))
 129   (while (eq (char-before) ?\n) (backward-delete-char 1))
 130   (goto-char (point-min))
 131   (if (eobp)
 132       (insert "\"\"")
 133     (while (not (eobp))
 134       (insert "\t    \"")
 135       (end-of-line)
 136       (insert (if (eobp) "\"" "\\n\""))
 137       (forward-line 1)))
 138   (let ((doc (buffer-string)))
 139     (kill-buffer (current-buffer))
 140     (delete-window (selected-window))
 141     (let ((region (guile-c-find-docstring)))
 142       (goto-char (car region))
 143       (delete-region (car region) (cdr region)))
 144     (insert doc)))
 145
 146 (defun guile-c-find-docstring ()
 147   (save-excursion
 148     (if (re-search-backward "^SCM_DEFINE" nil t)
 149         (let ((start (progn (forward-line 2) (point))))
 150           (while (looking-at "[ \t]*\"")
 151             (forward-line 1))
 152           (cons start (- (point) 2))))))
 153
 154 (provide 'guile-c)
 155
 156 ;; guile-c.el ends here