仮置き: cl 用の小物（作りかけ）

適当に作った 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}"

;;; compile-ccl.lisp ends here