実行可能ファイル作成補助マクロ(sbcl)

sbcl(1.0.28)では、実行可能ファイルを作成することができる。

> (sb-ext:save-lisp-and-die "実行可能ファイル名" :toplevel #'エントリ関数 :executable t)

エントリ関数には(必須引数の数が0個なら?)どのような関数でも指定可能なのだが、いろいろクセがあるため期待通りに動く関数を一から作成するのは、若干手間取ったりする。

なので、エントリ関数作成用のマクロを作成した。
そこまで汎用的ではないので、その時々で手を加える必要があるとは思うが、テンプレートとしては十分だと思う。


以下コード:

;; パスのファイル名部分を取り出す
(defun basename (pathstring)
  (let ((path (parse-namestring pathstring)))
    (format nil "~A~@[.~A~]" 
            (pathname-name path)
            (pathname-type path))))

;; '(a b c &optional c &key (d e)) -> '(a b c d)
(defun collect-varsym (arguments)
  (mapcar
   (lambda (a)
     (if (consp a) (car a) a))
   (remove-if (lambda (a)
                (and (symbolp a) (string= "&" a :end2 1)))
              arguments)))

(defmacro defmain (fn-name args &body body)
  (let ((usage nil))
    ;; bodyの一番初めの式が文字列の場合は、コマンドの説明文だと判断
    (when (stringp (car body))
      (setf usage (car body)
            body (cdr body)))
    
    `(defun ,fn-name ()
       ;; *invoke-debugger-hook*は上書きする必要あり (下記の理由により)
       ;;   1] Ctrl-Cなどで(まともに)中断できなくなる
       ;;   2] 他のコマンドと連携する際に、ハンドルしていないコンディションが送出されると
       ;;      sbclのデバッグモードに入って処理が止まってしまう
       (let ((sb-ext:*invoke-debugger-hook*
               (lambda (condition hook)
                 (declare (ignore hook))
                 (format *error-output* "Error: ~A~%" condition)
                 ;; エラー時は、1を返す
                 (sb-ext:quit :unix-status 1))))
         
         ;; 引数の分配に失敗した場合は、コマンドの説明文を表示して終了する
         ,(when usage
            `(handler-case 
                (destructuring-bind ,args (cdr sb-ext:*posix-argv*) 
                  (declare (ignore ,@(collect-varsym args))))
              (error ()
                (format *error-output* "~&~?~%~%" 
                        ,usage
                        (list (basename (car sb-ext:*posix-argv*))))
                ;; エラー時は、1を返す
                (sb-ext:quit :unix-status 1))))

         ;; メインの処理を実行
         ;; TODO: getopt風の引数指定をキーワード引数で扱えるようにしたら便利かもしれない
         (destructuring-bind ,args (cdr sb-ext:*posix-argv*)
           ,@body
           
           ;; body内で明示的にquitを呼び出していない場合は0を返す
           ;; ※ bodyの評価結果が '(signed-byte 32) 以外の値を返すと(プログラム終了時に)エラーになるので、その対処
           (sb-ext:quit :unix-status 0))))))


使用例:

;; コマンド(実行可能ファイル)の説明なし
(defmain main (a b &optional c) 
  (print `(,a ,b ,c)))

;; コマンドの説明あり
(defmain main (a b &optional c) 
  "Usage: ~A a b [c]"
  (print `(,a ,b ,c)))

;; 作成
> (save-lisp-and-die "a.out" :toplevel #'main :executable t)

;; シェル
# ./a.out 1 2 3
("1" "2" "3")    ; 引数は全部文字列  ※ optional引数が省略された場合は除く

# ./a.out 1 2
("1" "2" nil)

# ./a.out 1
Usage: a.out a b [c]

おまけ

sbcl(他の処理系でも同様?)の実行可能ファイルやスクリプト内で、read系の関数を呼び出す時は、基本的に、第一引数(stream指定)にtを指定しないよう注意する必要がある。
common lispの第二版の仕様書には、read系の関数は第一引数にnilを渡した場合は*standard-input*を使い、tを渡した場合は*terminal-io*を使う、とある。
このためか、パイプなどで入出力を繋いでいる場合でも、(read t)などと書くと、パイプ元からではなくコンソールから(ユーザの)入力を読み込もうとするので、それを意図していない場合はブロッキングが起こってしまう。