123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179 |
- (require 'cc-mode)
- (defvar guile-c-prefix "scm_")
- (defun guile-c-insert-define ()
- "Insert a template of a Scheme procedure.
- M-x guile-c-insert-define RET foo arg , opt . rest =>
- SCM_DEFINE (scm_foo, \"foo\", 1, 1, 1,
- (SCM arg, SCM opt, SCM rest),
- \"\")
- #define FUNC_NAME s_scm_foo
- {
-
- }
- #undef FUNC_NAME"
- (interactive)
- (let ((tokens (split-string (read-string "Procedure: ")))
- name args opts rest)
-
- (if (not tokens) (error "No procedure name"))
- (setq name (car tokens) tokens (cdr tokens))
-
- (while (and tokens (not (member (car tokens) '("," "."))))
- (setq args (cons (car tokens) args) tokens (cdr tokens)))
- (setq args (nreverse args))
-
- (when (string= (car tokens) ",")
- (setq tokens (cdr tokens))
- (while (and tokens (not (string= (car tokens) ".")))
- (setq opts (cons (car tokens) opts) tokens (cdr tokens)))
- (setq opts (nreverse opts)))
-
- (when (string= (car tokens) ".")
- (setq rest (list (cadr tokens))))
-
- (let ((c-name (guile-c-name-from-scheme-name name)))
- (insert (format "SCM_DEFINE (%s, \"%s\", %d, %d, %d,\n"
- c-name name (length args) (length opts) (length rest))
- "\t ("
- (mapconcat (lambda (a) (concat "SCM " a))
- (append args opts rest) ", ")
- "),\n"
- "\t \"\")\n"
- "#define FUNC_NAME s_" c-name "\n"
- "{\n\n}\n"
- "#undef FUNC_NAME\n\n")
- (previous-line 4)
- (indent-for-tab-command))))
- (defun guile-c-name-from-scheme-name (name)
- (while (string-match "\\?$" name) (setq name (replace-match "_p" t t name)))
- (while (string-match "!$" name) (setq name (replace-match "_x" t t name)))
- (while (string-match "^%" name) (setq name (replace-match "sys_" t t name)))
- (while (string-match "->" name) (setq name (replace-match "_to_" t t name)))
- (while (string-match "[-:]" name) (setq name (replace-match "_" t t name)))
- (concat guile-c-prefix name))
- (defvar guile-c-window-configuration nil)
- (defun guile-c-edit-docstring ()
- (interactive)
- (let* ((region (guile-c-find-docstring))
- (doc (if region (buffer-substring (car region) (cdr region)))))
- (if (not doc)
- (error "No docstring!")
- (setq guile-c-window-configuration (current-window-configuration))
- (with-current-buffer (get-buffer-create "*Guile Docstring*")
- (erase-buffer)
- (insert doc)
- (goto-char (point-min))
- (while (not (eobp))
- (if (looking-at "[ \t]*\"")
- (delete-region (match-beginning 0) (match-end 0)))
- (end-of-line)
- (if (eq (char-before (point)) ?\")
- (delete-backward-char 1))
- (if (and (eq (char-before (point)) ?n)
- (eq (char-before (1- (point))) ?\\))
- (delete-backward-char 2))
- (forward-line))
- (goto-char (point-min))
- (texinfo-mode)
- (if global-font-lock-mode
- (font-lock-fontify-buffer))
- (local-set-key "\C-c\C-c" 'guile-c-edit-finish)
- (setq fill-column 63)
- (switch-to-buffer-other-window (current-buffer))
- (message "Type `C-c C-c' to finish")))))
- (defun guile-c-edit-finish ()
- (interactive)
- (goto-char (point-max))
- (while (eq (char-before) ?\n) (backward-delete-char 1))
- (goto-char (point-min))
- (if (eobp)
- (insert "\"\"")
- (while (not (eobp))
- (insert "\t \"")
- (end-of-line)
- (insert (if (eobp) "\"" "\\n\""))
- (forward-line 1)))
- (let ((doc (buffer-string)))
- (kill-buffer (current-buffer))
- (set-window-configuration guile-c-window-configuration)
- (let ((region (guile-c-find-docstring)))
- (goto-char (car region))
- (delete-region (car region) (cdr region)))
- (insert doc)))
- (defun guile-c-find-docstring ()
- (save-excursion
- (if (re-search-backward "^SCM_DEFINE" nil t)
- (let ((start (progn (forward-line 2) (point))))
- (while (looking-at "[ \t]*\"")
- (forward-line 1))
- (cons start (- (point) 2))))))
- (defun guile-c-deprecate-region (start end)
- (interactive "r")
- (save-excursion
- (let ((marker (make-marker)))
- (set-marker marker end)
- (goto-char start)
- (insert "#if (SCM_DEBUG_DEPRECATED == 0)\n\n")
- (goto-char marker)
- (insert "\n#endif /* (SCM_DEBUG_DEPRECATED == 0) */\n"))))
- (provide 'guile-c)
|