You are looking at historical revision 26833 of this page. It may differ significantly from its current revision.

Author: Dan Leslie, <dan@ironoxide.ca>

I do a fair bit of Chicken hacking in my free time as a hobby. Sadly, there wasn't much in the way of excellent tools for this purpose when I began. Largely, in part, because I was never able to get slime to play well with Emacs and Chicken under Windows.

To rectify this I put in some time to get my Emacs environment working nicely. The end result is a customized scheme-mode that automatically loads all symbols from csi and your installed modules and adds them to the auto-complete list. It also uses these details to add new font-lock keywords!

Optionally, you can also tell it (via a custom var) where to look for a TAGS file to slurp symbols from.

The major bug I'm aware of is that the font-lock symbols get blown away on file load, so you may have to manually reload scheme-mode to reinit the symbols. You could also call M-x load-chicken-keywords

If you figure out how to fix this please let me know!

Without further ado, the elisp:

(require 'paredit)
(require 'auto-complete)
(require 'auto-complete-etags)
(require 'yasnippet-bundle)
(require 'scheme)

; Some utilities of mine
(defun add-font-lock-keywords (modes new-keywords)
  (mapc (lambda (mode)
          (font-lock-add-keywords mode `((, (concat "(\\(" (regexp-opt (mapcar 'symbol-name (remove-if 'numberp new-keywords)) t) "\\)\\>")
                                            (1 font-lock-keyword-face)))))
        modes)
  t)

(defun remove-font-lock-keywords (modes new-keywords)
  (mapc (lambda (mode)
          (font-lock-remove-keywords mode `((, (concat "(\\(" (regexp-opt (mapcar 'symbol-name (remove-if 'numberp new-keywords)) t) "\\)\\>")
                                            (1 font-lock-keyword-face)))))
        modes)
  t)

; Set this to a target etags file of your choosing
(defcustom chicken-scheme-tags-file nil
  "Extra tags file to load for pattern matching and syntax hilighting"
  :type '(string)
  :group 'chicken-scheme)

(setq r5rs-symbols '(abs acos and angle append apply asin assoc assq assv atan begin boolean? caar cadr call-with-current-continuation call-with-input-file call-with-output-file call-with-values car case cdddar cddddr cdr ceiling char->integer char-alphabetic? char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase char-lower-case? char-numeric? char-ready? char-upcase char-upper-case? char-whitespace? char<=? char<? char=? char>=? char>? char? close-input-port close-output-port complex? cond cons cos current-input-port current-output-port define define-syntax delay denominator display do dynamic-wind else eof-object? eq? equal? eqv? eval even? exact->inexact exact? exp expt floor for-each force gcd if imag-part inexact->exact inexact? input-port? integer->char integer? interaction-environment lambda lcm length let let* let-syntax letrec letrec-syntax list list->string list->vector list-ref list-tail list? load log magnitude make-polar make-rectangular make-string make-vector map max member memq memv min modulo negative? newline not null-environment null? number->string number? numerator odd? open-input-file open-output-file or output-port? pair? peek-char port? positive? procedure? quasiquote quote quotient rational? rationalize read read-char real-part real? remainder reverse round scheme-report-environment set! set-car! set-cdr! setcar sin sqrt string string->list string->number string->symbol string-append string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>? string-copy string-fill! string-length string-ref string-set! string<=? string<? string=? string>=? string>? string? substring symbol->string symbol? syntax-rules tan transcript-off transcript-on truncate values vector vector->list vector-fill! vector-length vector-ref vector-set! vector? with-input-from-file with-output-to-file write write-char zero?))

(defun load-scheme-tags (scheme-tags-location)
  (interactive)
  (let ((existing-tags tags-table-list))
    (setq tags-table-list nil)
    (visit-tags-table scheme-tags-location)
    (tags-completion-table)
    (add-font-lock-keywords '(scheme-mode inferior-scheme-mode) tags-completion-table)
    (setq tags-table-list existing-tags))
  t)

(defun chicken-modules ()
  (interactive "r")
  (let ((default-directory "~/")
        modules)
    (with-temp-buffer
      (insert (shell-command-to-string "chicken-status -files"))
      (beginning-of-buffer)
      (while (re-search-forward "/\\([^/\.]+\\)\\.so" nil t)
        (when (match-string 0)
          (if (and (not (equalp "chicken-doc" (match-string 1))) ; Doesn't play well with csi in emacs?
                   (not (equalp "chicken-doc-text" (match-string 1)))
                   (not (equalp "allegro" (match-string 1))) ; Has problems with csi in emacs on windows
                   (not (equalp "sfml" (match-string 1))) ; Has problems with csi in emacs on windows
                   (not (equalp "bind-translator" (match-string 1))))
              (push (match-string 1) modules)))))
    modules))

(defun chicken-symbols ()
  (interactive "r")
  (let ((modules (mapconcat 'identity (chicken-modules) " "))
        symbols)
    (with-temp-buffer
      (insert (shell-command-to-string (format "csi -e \"(use %s)\" -e \"(map car (##sys#macro-environment))\"" modules)))
      (beginning-of-buffer)
      (while (re-search-forward "[^ ()]+" nil t)
        (when (match-string 0)
          (push (make-symbol (match-string 0)) symbols))))
    symbols))

(defvar ac-chicken-symbols-source
  (let* ((modules (mapconcat 'identity (chicken-modules) " "))
         (symbols (eval (read (concat "'" (shell-command-to-string (format "csi -q -w -e \"(use %s)\" -e \"(display (map car (##sys#macro-environment)))\"" modules)))))))
    symbols))

(defun all-chicken-symbols ()
  (delete-dups (append r5rs-symbols ac-chicken-symbols-source)))

(defun ac-chicken-symbols-candidates ()
  (delq nil
        (mapcar '(lambda (s) (let ((n (symbol-name s)))
                               (cons n n)))
                (append r5rs-symbols ac-chicken-symbols-source))))

(defface ac-chicken-scheme-candidate-face
  '((t (:inherit 'ac-candidate-face)))
  "Face for chicken scheme candidate menu."
  :group 'chicken-scheme)
 
(defface ac-chicken-scheme-selection-face
  '((t (:inherit 'ac-selection-face)))
  "Face for the chicken scheme selected candidate."
  :group 'chicken-scheme)

(defun ac-chicken-doc (symbol-name)
  (shell-command-to-string (format "chicken-doc %s" (substring-no-properties symbol-name))))

(defvar ac-source-scheme-symbols
  '((init . (lambda () t))
    (candidates . ac-chicken-symbols-candidates)
    (candidate-face . ac-chicken-scheme-candidate-face)
    (selection-face . ac-chicken-scheme-selection-face)
    (symbol . "c")
    (requires . 3)
    (document . ac-chicken-doc)
    (cache))
  "Source for chicken scheme completions")

(defun load-chicken-keywords ()
  (interactive "r")
  (add-font-lock-keywords '(scheme-mode) (all-chicken-symbols)))

(add-hook 'scheme-mode-hook
          '(lambda ()
                        (enable-paredit-mode)
                        (if chicken-scheme-tags-file
                            (load-scheme-tags scheme-tags-file))
                        (auto-complete-mode)
                        (make-local-variable 'ac-sources)   
                        (setq ac-sources 
                              '(ac-source-scheme-symbols
                                ac-source-words-in-buffer
                                ac-source-words-in-same-mode-buffers
                                ;ac-source-abbrev
                                ;ac-source-yasnippet
                                ))
                        (load-chicken-keywords)))

(provide 'custom-scheme)