~ chicken-core (chicken-5) /misc/chicken.el
Trap1;;;; chicken.el - Scheme mode modified for use with CHICKEN234(require 'cmuscheme)5(require 'cl)67(define-key scheme-mode-map "\C-c\C-l" 'chicken-load-current-file)8(define-key scheme-mode-map "\C-c\C-k" 'chicken-compile-current-file)9(define-key scheme-mode-map "\C-x\C-e" 'chicken-send-last-sexp-with-info)10(define-key scheme-mode-map "\C-c\C-a" 'chicken-apropos)11(define-key scheme-mode-map "\C-c\C-t" 'chicken-trace)12(define-key scheme-mode-map "\C-c\C-c" 'scheme-compile-definition)1314(define-key scheme-mode-map "\C-c\C-d" 'chicken-doc)15(define-key scheme-mode-map "\C-c\C-g" 'scheme-grep-current-word)16(define-key inferior-scheme-mode-map "\C-c\C-g" 'scheme-grep-current-word)17(define-key inferior-scheme-mode-map "\C-c\C-d" 'chicken-doc)18(define-key inferior-scheme-mode-map "\C-c\C-t" 'chicken-trace)19(define-key inferior-scheme-mode-map "\C-c\C-a" 'chicken-apropos)2021(defun chicken-load-current-file (&optional switch)22 (interactive "P")23 (let ((file-name (buffer-file-name)))24 (comint-check-source file-name)25 (setq chicken-prev-l/c-dir/file26 (cons (file-name-directory file-name)27 (file-name-nondirectory file-name)))28 (comint-send-string29 (scheme-proc)30 (concat "(begin (load \"" file-name "\"\) (newline))\n"))31 (if switch32 (switch-to-scheme t)33 (message "\"%s\" loaded." file-name) ) ) )3435(defun chicken-compile-current-file (&optional switch)36 (interactive "P")37 (let ((file-name (buffer-file-name)))38 (comint-check-source file-name)39 (setq chicken-prev-l/c-dir/file40 (cons (file-name-directory file-name)41 (file-name-nondirectory file-name)))42 (message "compiling \"%s\" ..." file-name)43 (comint-send-string44 (scheme-proc)45 (concat "(compile-file \"" file-name "\"\)\n"))46 (if switch47 (switch-to-scheme t)48 (message "\"%s\" compiled and loaded." file-name) ) ) )4950(defun chicken-send-last-sexp-with-info ()51 "hacked version from cmuscheme.el"52 (interactive)53 (let* ((str (buffer-substring (save-excursion (backward-sexp) (point)) (point)))54 (lnbreak (position ?\n str)))55 (comint-send-string (scheme-proc) str)56 (comint-send-string57 (scheme-proc)58 (concat59 "(display #<<EOFEOF\n\n;;; "60 (if lnbreak61 (substring str 0 lnbreak)62 str)63 " ...\n\nEOFEOF\n)\n"))))6465(defun chicken-doc (&optional arg)66 (interactive "P")67 (let ((words68 (if current-prefix-arg69 (split-string (read-from-minibuffer "chicken-doc: ") " ")70 (list (current-word)))))71 (unless (null words)72 (run-chicken-doc words))))7374(defun chicken-toc (&optional arg)75 (interactive "P")76 (let ((words77 (if current-prefix-arg78 (split-string (read-from-minibuffer "chicken-doc: ") " ")79 (list (current-word)))))80 (unless (null words)81 (run-chicken-doc (cons "-c" words)))))8283(defun run-chicken-doc (args)84 (with-current-buffer (get-buffer-create "*chicken-doc*")85 (erase-buffer)86 (when (zerop (apply 'call-process "chicken-doc" nil "*chicken-doc*" t args))87 (goto-char (point-min))))88 (unless (string= "*chicken-doc*" (buffer-name (current-buffer)))89 (display-buffer "*chicken-doc*" t)))9091(defun chicken-apropos ()92 (interactive)93 (let ((func (current-word)))94 (when func95 (process-send-string "*scheme*" (concat "(begin (newline) (apropos \"" func "\"))\n"))96 (unless (string= (buffer-name (current-buffer)) "*scheme*")97 (display-buffer "*scheme*" t)))))9899(defun chicken-trace ()100 (interactive)101 (let ((func (current-word)))102 (when func103 (process-send-string "*scheme*" (concat "(begin (newline) (trace/untrace " func "))\n"))104 (unless (string= (buffer-name (current-buffer)) "*scheme*")105 (display-buffer "*scheme*" t)))))106107(defun scheme-grep-current-word (&optional arg)108 (interactive "P")109 (let ((word (or (and (not current-prefix-arg)110 (current-word))111 (read-from-minibuffer112 (concat grep-command " <word> *.scm: ")))))113 (grep (concat grep-command " \'" word "\' " "*.scm"))))114115(setq scheme-program-name "csi -:c")116117(setq chicken-keyword-list118 '((receive 2)119 (match 1)120 (match-lambda 0)121 (match-lambda* 0)122 (match-let scheme-let-indent)123 (match-let* 1)124 (match-letrec 1)125 (declare 0)126 (cond-expand 0)127 (let-values scheme-let-indent)128 (let*-values scheme-let-indent)129 (letrec-values 1)130 (letrec* 1)131 (parameterize scheme-let-indent)132 (let-location 1)133 (foreign-lambda 2)134 (foreign-lambda* 2)135 (foreign-primitive 2)136 (foreign-safe-lambda 2)137 (foreign-safe-lambda* 2)138 (set! 1)139 (let-optionals* 2)140 (let-optionals 2)141 (condition-case 1)142 (fluid-let 1)143 (and-let* 1)144 (assume 1)145 (cut 1)146 (cute 1)147 (when 1)148 (unless 1)149 (dotimes 1)150 (compiler-typecase 1)151 (ecase 1)152 (require-extension 0)153 (import 0)154 (handle-exceptions 2)155 (regex-case 1)156 (define-inline 1)157 (define-constant 1)158 (define-syntax-rule 1)159 (define-record-type 1)160 (define-values 1)161 (define-record 1)162 (define-specialization 1)163 (define-type 1)164 (with-input-from-pipe 1)165 (select 1)166 (functor 3)167 (define-interface 1)168 (module 2)) )169170(setq chicken-indent-list171 '((printf 1)172 (fprintf 2)173 (sprintf 1)174 (set-record-printer! 1)))175176;(put 'module 'scheme-indent-function 'chicken-module-indent)177;(defun chicken-module-indent (state indent-point normal-indent) 0)178179(defun chicken-build-keyword-regexp (kwl)180 (let ((str "\\<\\(module\\>"))181 (dolist (kw kwl)182 (put (car kw) 'scheme-indent-hook (cadr kw))183 (setq str (concat str "\\|" (regexp-quote (symbol-name (car kw))) "\\>")))184 (concat str "\\)")))185186(setq chicken-keyword-regexp187 (chicken-build-keyword-regexp chicken-keyword-list))188189(dolist (e chicken-indent-list)190 (put (car e) 'scheme-indent-hook (cadr e)))191192(add-hook193 'scheme-mode-hook194 (lambda ()195 (font-lock-add-keywords196 'scheme-mode197 `(("\\<\\sw+\\>:" . font-lock-constant-face) ;XXX doesn't work, yet198 ("##\\(core\\|sys\\)#\\sw+\\>" . font-lock-builtin-face)199 (,chicken-keyword-regexp . font-lock-keyword-face)200 )201 1)))202203(provide 'chicken)