Commit | Line | Data |
---|---|---|
de41117e KN |
1 | ;;; guile-c.el --- Guile C editing commands |
2 | ||
e41561b4 | 3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. |
de41117e KN |
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 |