guile-for-guile-emacs/emacs/guile-c.el

;;; guile-c.el --- Guile C editing commands

;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;;; 02111-1307 USA

;;; Commentary:

;; (add-hook 'c-mode-hook
;;   (lambda ()
;;     (require 'guile-c)
;;     (define-key c-mode-map "\C-c\C-g\C-p" 'guile-c-insert-define)
;;     (define-key c-mode-map "\C-c\C-g\C-e" 'guile-c-edit-docstring)
;;     (define-key c-mode-map "\C-c\C-g\C-d" 'guile-c-deprecate-region)
;;     ))

;;; Code:

(require 'cc-mode)

(defvar guile-c-prefix "scm_")


;;;
;;; Insert templates
;;;

(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)
    ;; Get procedure name
    (if (not tokens) (error "No procedure name"))
    (setq name (car tokens) tokens (cdr tokens))
    ;; Get requisite arguments
    (while (and tokens (not (member (car tokens) '("," "."))))
      (setq args (cons (car tokens) args) tokens (cdr tokens)))
    (setq args (nreverse args))
    ;; Get optional arguments
    (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)))
    ;; Get rest argument
    (when (string= (car tokens) ".")
      (setq rest (list (cadr tokens))))
    ;; Insert template
    (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))


;;;
;;; Edit docstrings
;;;

(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))))))


;;;
;;; Others
;;;

(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)

;; guile-c.el ends here