適当に作った clozure CL 用の cl-mode と、その native-compile 用のコマンド。
scheme-mode をパクらせていただいた。
念のために、作りかけを置いとく。プロセス周りがかなり怪しい。
cl-mode.l
;;; -*- Mode: Lisp; Package: EDITOR -*- ;;; ;;; ; cl-mode ; based on scheme-mode (wrote by MATSUOKA Hiroshi) ; (require "lispmode") (provide "cl-mode") (in-package "editor") (export '(*cl-mode-hook* *cl-keyword-file* *cl-mode-map* *cl-indent-map* cl-mode *cl-run-command* *cl-run-pop-to-args* make-cl-scratch *cl-mode-scratch-buffer* *cl-process* *cl-process-open-hook* *cl-process-close-hook* *cl-process-send-filter* *cl-process-read-filter* *cl-view-mode-map* *cl-mode-version* cl-view-mode)) (defvar *cl-mode-version* "based-scheme-mode-20090118") ;;; cl-mode (defvar *cl-mode-map* nil) (unless *cl-mode-map* (setq *cl-mode-map* (make-sparse-keymap)) (define-key *cl-mode-map* #\RET 'lisp-newline-and-indent) (define-key *cl-mode-map* #\LFD #'(lambda () (interactive) (cl-eval-last-sexp) (newline))) (define-key *cl-mode-map* '(#\C-c #\C-e) 'cl-eval-current-buffer) (define-key *cl-mode-map* #\TAB 'lisp-indent-line) ) (defvar *cl-process* nil) (defvar *cl-process-open-hook* 'cl-default-open-hook) (defvar *cl-process-close-hook* nil) (defvar *cl-process-send-filter* 'cl-default-send-filter) (defvar *cl-process-read-filter* 'cl-default-read-filter) (defvar *cl-run-command* nil) (defvar *cl-run-pop-to-args* nil) (defvar *cl-keyword-hash-table* nil) (defvar *cl-keyword-file* "cl") (defvar *cl-mode-scratch-buffer* "*cl scratch*") (defun cl-default-send-filter (proc sexp) (format nil "~A\r\n" sexp)) (defun cl-default-read-filter (proc text) (when *cl-run-pop-to-args* (unless (find-buffer (car *cl-run-pop-to-args*)) (save-excursion (switch-to-buffer (car *cl-run-pop-to-args*)) (setup-temp-buffer (selected-buffer)))) (apply 'pop-to-buffer *cl-run-pop-to-args*)) (insert text) (set-window (get-buffer-window (process-buffer proc))) (refresh-screen)) (defun cl-default-open-hook (buffer) (set-buffer buffer) (make-process *cl-run-command*)) (defun cl-open-process () (interactive) (when (null *cl-process*) (let* ((process (funcall *cl-process-open-hook* (selected-buffer)))) (setf *cl-process* process) (when *cl-process* (set-process-sentinel *cl-process* #'(lambda (proc) (when *cl-process-close-hook* (funcall *cl-process-close-hook* proc)) (setf *cl-process* nil))) (set-process-filter *cl-process* *cl-process-read-filter*)))) *cl-process*) (defun cl-eval-string (sexp) (when sexp (let ((process (cl-open-process))) (when process (process-send-string process (funcall *cl-process-send-filter* process sexp)))))) (defun cl-eval-current-buffer () (interactive) (let* ((text (buffer-substring (point-min) (point-max)))) (when (and text (> (length text) 0)) (cl-eval-string text)))) (defun cl-eval-last-sexp() (interactive) (save-excursion (let* ((p (point)) (s (progn (backward-sexp) (point))) (e (progn (forward-sexp) (point))) (text (buffer-substring s e))) (goto-char p) (when (and text (> (length text) 0)) (cl-eval-string text))))) (defvar *cl-mode-abbrev-table* nil) (unless *cl-mode-abbrev-table* (define-abbrev-table '*cl-mode-abbrev-table*)) ; completion (defvar *cl-completion-list* nil) (defun cl-completion () (interactive) (or *cl-completion-list* (setq *cl-completion-list* (make-list-from-keyword-table *cl-keyword-hash-table*)) (return-from cl-completion nil)) (let ((opoint (point))) (when (skip-syntax-spec-backward "w_") (let ((from (point))) (goto-char opoint) (do-completion from opoint :list *cl-completion-list*))))) (defvar *cl-mode-hook* nil) (defun cl-mode () (interactive) (kill-all-local-variables) (setq mode-name "CL") (setq buffer-mode 'cl-mode) (use-keymap *cl-mode-map*) (use-syntax-table *lisp-mode-syntax-table*) (and *cl-keyword-file* (null *cl-keyword-hash-table*) (setq *cl-keyword-hash-table* (load-keyword-file *cl-keyword-file* t))) (when *cl-keyword-hash-table* (make-local-variable 'keyword-hash-table) (setq keyword-hash-table *cl-keyword-hash-table*)) (when *cl-mode-abbrev-table* (setq *local-abbrev-table* *cl-mode-abbrev-table*)) (run-hooks '*cl-mode-hook*)) (defun make-cl-scratch () (interactive) (switch-to-buffer *cl-mode-scratch-buffer*) (cl-mode) (make-local-variable 'need-not-save) (setf need-not-save t) (make-local-variable 'auto-save) (setf auto-save nil)) ;;; cl-mode.l ends here
cl-native-compile.l
;;; cl-native-compile.l ;;; (require "cl-mode") (provide "cl-native-compile") (defvar *cl-native-compile-template* (merge-pathnames "etc/cl-compile-template-ccl" (si:system-root)) "コンパイルスクリプトを生成するテンプレートファイルを指定") (defvar *cl-native-compile-script-name* "compile-ccl.lisp" "コンパイルスクリプトのファイル名") (defvar *cl-native-compile-top-level-func-name* nil "トップレベル関数の名前を文字列で指定する。 nil なら、ソースファイルの一番上の defun をトップレベル関数とみなす。") (defun cl-native-compile () (interactive) (let ((fn (get-buffer-file-name)) (ext "lisp")) (if (interactive-p) (cond (fn (when (and (buffer-modified-p) (string= (pathname-type fn) ext)) (save-buffer)) (call-interactively 'cl-native-compile-1)) (t (call-interactively 'emacs-write-file) (cl-native-compile-internal (get-buffer-file-name)))) (cl-native-compile-internal fn)))) (defun cl-native-compile-1 (filename) (interactive "fNative compile file: " :default0 (get-buffer-file-name)) (cl-native-compile-internal filename)) (defun cl-native-compile-internal (filename) (let ((script (cl-native-compile-create-compile-script filename))) (when script (cl-native-compile-kick-compile-command script)))) (defun cl-native-compile-kick-compile-command-dos (script) "DOS窓を開いてコンパイルを実行する。" (let* ((ccl (map-slash-to-backslash *cl-run-command*)) (script (pathname-name script)) (dir (directory-namestring script)) (cmd (format nil "cmd.exe /c ~A --no-init --load ~A" ccl script))) (call-process cmd :exec-directory dir :show :show) cmd)) (defun cl-native-compile-kick-compile-command (script) "バッファを開いてコンパイルを実行する。" (let* ((ccl (map-slash-to-backslash *cl-run-command*)) (script (pathname-name script)) (dir (directory-namestring script)) (cmd (format nil "~A --no-init --load ~A" ccl script)) (buf (get-buffer-create "*cl-native-compile*")) (proc (progn (execute-subprocess cmd nil buf nil dir) (buffer-process buf)))) (sleep-for 0.5) (switch-to-buffer buf) ;(process-send-string proc (concat cmd "\n")) ;(insert "\n") ;(kill-process proc) cmd)) (defun cl-native-compile-create-compile-script (lisp-path) "native compile 用のスクリプトを生成しファイル名を返す。すでにある場合は生成せず、そのファイル名を返す。" (let ((template *cl-native-compile-template*) (script (merge-pathnames *cl-native-compile-script-name* (directory-namestring lisp-path))) temp-buffer top-level ret) (cond ((file-exist-p script) (setq ret script)) ((null (file-exist-p lisp-path)) (error "ソースファイル ~A がありません。" src)) ((null (file-exist-p template)) (error "テンプレートファイル ~A がありません。" template)) (t (unwind-protect (progn (setq temp-buffer (create-new-buffer "*cl-native-compile*")) (set-buffer temp-buffer) (insert-file-contents lisp-path) (setq top-level (cl-native-compile-get-top-level-func)) (cond ((null top-level) (error "トップレベル関数が見つかりません。")) (t (progn (erase-buffer temp-buffer) (insert-file-contents template) (cl-native-compile-replace-template lisp-path top-level) (write-file script) (setq ret script))))) (when temp-buffer (delete-buffer temp-buffer))))) ret)) (defun cl-native-compile-replace-template (lisp-path top) (let ((src (file-namestring lisp-path)) (exe (concat (pathname-name lisp-path) ".exe"))) (goto-char (point-min)) (replace-buffer "{TIME-STAMP}" (format-date-string "%Y.%#m.%#d %H:%M:%S (%z)") :once t) (goto-char (point-min)) (replace-buffer "{SRC-NAME}" src) (goto-char (point-min)) (replace-buffer "{EXE-NAME}" exe) (goto-char (point-min)) (replace-buffer "{TOP-LEVEL-FUNC}" top :once t) (goto-char (point-min)))) (defun cl-native-compile-get-top-level-func () "ソースファイルからトップレベル関数を探して関数名を返す。 もし、*cl-native-compile-top-level-func-name* が non-nil なら探さずに、無条件にその値を返す。" (cond (*cl-native-compile-top-level-func-name*) (t (let ((re "^ *( *defun +\\(.+\\) +")) (if (scan-buffer re :regexp t) (match-string 1) nil)))))
clozure CL 用の設定
;;; cl-mode (require "cl-mode") (push '("\\.lisp$" . cl-mode) *auto-mode-alist*) ; インタプリタの起動コマンド (clozure CL) (setf *cl-run-command* (format nil "\"~A\"" (map-slash-to-backslash "D:/util/ccl/wx86cl.exe"))) ; インデントを空白に (add-hook '*cl-mode-hook* #'(lambda () (ed::set-buffer-local 'indent-tabs-mode nil))) ; 評価結果を別窓にしたい場合 (setf *cl-run-pop-to-args* '("*cl run*" 2 nil)) (define-key *cl-mode-map* #\LFD #'(lambda () (interactive) (ed::cl-eval-last-sexp))) (defalias 'cl 'make-cl-scratch)
xyzzy/etc/cl-compile-template-ccl（コンパイル用のテンプレートファイル）
;;; compile-ccl.lisp ;;; ;;; compile script for Clozure CL ;;; THIS FILE IS AUTOMATICALLY CREATED BY `cl-native-compile.l'. ;;; ;;; created: {TIME-STAMP} ;;; source: {SRC-NAME} ;;; out: {EXE-NAME} (load "./{SRC-NAME}") (format t "now compiling...") (ccl:save-application "{EXE-NAME}" :toplevel-function #'{TOP-LEVEL-FUNC} :prepend-kernel t) ;;; compile-ccl.lisp ends here
