1 ;;; guile-c.el --- Guile C editing commands
3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
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)
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.
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.
22 ;; (add-hook 'c-mode-hook
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)
34 (defvar guile-c-prefix
"scm_")
41 (defun guile-c-insert-define ()
42 "Insert a template of a Scheme procedure.
44 M-x guile-c-insert-define RET foo arg , opt . rest =>
46 SCM_DEFINE (scm_foo, \"foo\", 1, 1, 1,
47 (SCM arg, SCM opt, SCM rest),
49 #define FUNC_NAME s_scm_foo
55 (let ((tokens (split-string (read-string "Procedure: ")))
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
)))
71 (when (string= (car tokens
) ".")
72 (setq rest
(list (cadr tokens
))))
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
))
78 (mapconcat (lambda (a) (concat "SCM " a
))
79 (append args opts rest
) ", ")
82 "#define FUNC_NAME s_" c-name
"\n"
84 "#undef FUNC_NAME\n\n")
86 (indent-for-tab-command))))
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
))
101 (defvar guile-c-window-configuration nil
)
103 (defun guile-c-edit-docstring ()
105 (let* ((region (guile-c-find-docstring))
106 (doc (if region
(buffer-substring (car region
) (cdr region
)))))
108 (error "No docstring!")
109 (setq guile-c-window-configuration
(current-window-configuration))
110 (with-current-buffer (get-buffer-create "*Guile Docstring*")
113 (goto-char (point-min))
115 (if (looking-at "[ \t]*\"")
116 (delete-region (match-beginning 0) (match-end 0)))
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))
124 (goto-char (point-min))
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")))))
133 (defun guile-c-edit-finish ()
135 (goto-char (point-max))
136 (while (eq (char-before) ?
\n) (backward-delete-char 1))
137 (goto-char (point-min))
143 (insert (if (eobp) "\"" "\\n\""))
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
)))
153 (defun guile-c-find-docstring ()
155 (if (re-search-backward "^SCM_DEFINE" nil t
)
156 (let ((start (progn (forward-line 2) (point))))
157 (while (looking-at "[ \t]*\"")
159 (cons start
(- (point) 2))))))
166 (defun guile-c-deprecate-region (start end
)
169 (let ((marker (make-marker)))
170 (set-marker marker end
)
172 (insert "#if (SCM_DEBUG_DEPRECATED == 0)\n\n")
174 (insert "\n#endif /* (SCM_DEBUG_DEPRECATED == 0) */\n"))))
178 ;; guile-c.el ends here