gauche-apropos.el

(defvar gauche-apropos-result-list nil)

(defun eval-gauche-apropos (str)
  (process-send-string
   (scheme-proc)
   (format "(apropos '%s)\n" str)))

(defun gauche-apropos-filter (proc str)
  (insert str))

(defun gauche-apropos-list (str)
  (interactive "sApropos:")
  (if (not scheme-buffer)
      'no-scheme-buffer
    (let ((filter (process-filter (scheme-proc))))
      (flet ((message (&rest args) nil))
	(unwind-protect
	    (with-temp-buffer
	      (set-process-filter
	       (scheme-proc)
	       'gauche-apropos-filter)
	      (setf gauche-apropos-result-list nil)
	      (eval-gauche-apropos str)
	      (accept-process-output (scheme-proc) 0 100)
	      (goto-char (point-min))
	      (while (= (how-many "gosh>") 0)
		(goto-char (point-max))
		(accept-process-output (scheme-proc) 0 100)
		(goto-char (point-min)))
	      (set-process-filter
	       (scheme-proc)
	       filter)
	      (delete-matching-lines "gosh>")
	      (goto-char (point-min))
	      (do ()
		  ((= (point) (point-max)) 'done)
		(insert "\"")
		(forward-sexp)
		(insert "\" ;;")
		(unless (= (point) (point-max))
		  (move-beginning-of-line 2)))
	      (goto-char (point-min))
	      (insert "(")
	      (goto-char (point-max))
	      (insert ")")
	      (goto-char (point-min))
	      (setf gauche-apropos-result-list (read (current-buffer)))
	      gauche-apropos-result-list)
	  (set-process-filter (scheme-proc) filter))))))

(defun gauche-apropos-list-match-start (str)
  (let ((lst (gauche-apropos-list str))
	(len (length str)))
    (remove-if-not
     (lambda (s)
       (string= (substring s 0 len) str))
     lst)))

(defun sexp-at-point ()
  (save-excursion
    (let ((p (point))
	  (err nil))
      (condition-case nil
	(backward-sexp)
	(scan-error (setf err t)))
      (if err nil
	  (buffer-substring (point) p)))))

(defun gauche-apropos-list-at-point ()
  (let ((sexp (sexp-at-point)))
    (when sexp
      (gauche-apropos-list sexp))))

(defun gauche-apropos-at-point ()
  (let ((sexp (sexp-at-point)))
    (when sexp
      (gauche-apropos-list-match-start sexp))))

(defun gauche-apropos-completion-at-point ()
  (interactive)
  (let ((lst (gauche-apropos-at-point)))
    (when lst
      (if (null (cdr lst))
	  (progn
	    (backward-kill-sexp)
	    (insert (car lst)))
	  (let ((buf (get-buffer "*Gauche Apropos Completions*")))
	    (unless buf (setf buf (generate-new-buffer "*Gauche Apropos Completions*")))
	    (with-current-buffer buf
	      (mapcar (lambda (str) (insert (format "%s\n" str)))
		      lst)
	      (completion-list-mode)
	      (pop-to-buffer buf)))))))