AWKっぽいコードをLISPで書く

＿＿＿＿＿＿＿＿＿＿
　　　　＜○√
　　　　　‖　
　　　　 くく
しまった！　これは車輪の再発明だ！
ココは俺に任せて先に http://www.cliki.net/CLAWK に行け！

こんな感じでテキストファイルを処理するLISPユーティリティが欲しい。

(defawk parsing
    ;; letと同じ変数束縛。全てに先んじて束縛される。
    ;; 続くすべての節で、ここで定義した変数を使える。
    (sum)

  ;; レコードに対する繰り返しの前に実行される begin節
  (begin (setf sum 0))

  ;; レコードに対して毎回繰り返し実行される body節
  (body
   ;; body節の中はどんなLISPコードでもよい
   ;; ただし、matchではじまるリスト（match節）は、カレントレコードに対する
   ;; 正規表現のマッチを試し、マッチすれば実行されるようなコードとなる。
   (match "(\\w+)"
     ;; マッチ結果は $ 関数で参照できる
     (format t "MATCH: ~A in ~A~%" ($ 1) ($ 0))))
  (body
   ;; body節の処理中は、フィールドセパレータによって区切られた
   ;; フィールドを、 $f 関数で参照できる
   (format t "RECORD: ~A~%" ($f 0))
   (print *current-fields*)
   (print *number-of-fields*)
   (incf sum (read-from-string ($f 3))))

  ;; すべてのレコードに対する処理が終わった後に実行される end節
  (end (format t "TOTAL: ~A~%" sum)))

（何をしてるコードかはあんまり重要じゃない）

ということで書いてみた。

ちなみに、CL-PPCREに依存している。

;;; 設定できるオプション
(defvar *field-separator* "\\s+"
  "フィールドセパレーター。デフォルトでは、1つ以上の空白文字")


;;; *** マクロの中で使われる関数とスペシャル変数 ***

;;; それぞれの行を処理するときに、カレントのレコード、
;;; それが何番目のレコード化、分割されたフィールドのリスト
;;; そしてフィールドの数を記録しておくスペシャル変数。
(defvar *current-record* "")

(defvar *current-fields* nil)

(defvar *number-of-records* 0)

(defvar *number-of-fields* 0)

(defun update-record (record)
  "レコードを引数にして、上記のスペシャル変数を更新する関数"
  (setf *current-record*
	record
	*number-of-records* (1+ *number-of-records*)
	*current-fields*
	(cl-ppcre:split *field-separator* record))
  (setf *number-of-fields* (length *current-fields*)))


;;; レコードに対して正規表現でマッチをしようとしたときに、
;;; その結果、各レジスタを保持するリスト、レジスタの長さの
;;; 3つを記録しておくためのスペシャル変数
(defvar *matched* "")

(defvar *match-list* NIL)

(defvar *number-of-matches* 0)

(defun match (regexp)
  "引数として与えられた正規表現のマッチを試し、
その結果を上記のスペシャル変数にセットする"
  (multiple-value-bind (matched match-list)
      (cl-ppcre:scan-to-strings regexp *current-record*)
      (let ((len (length *match-list*)))
	(setf *matched* matched
	      *match-list* match-list
	      *number-of-matches* len))))


;;; *** ここからマクロを展開するための関数 ***

(defun check-clauses (clause-list)
  "各節が健全な切かどうかを試す関数
具体的には、それがbeginかbodyかendではじまるリストなら健全"
  (mapc (lambda (clause)
	  (unless (find (car clause) '(begin body end))
	    (error
	     "各節は begin, body, end のいずれかではじまるべき: ~S"
	     clause)))
	clause-list)
      t)


(defun pickup-clauses (sym clause-list)
  "節のリストの中から、ある種類の節だけを抜き出す

節はリストなので、第一引数で表されたシンボルではじまる節をすべて集め、
そのシンボルだけを取り除いた残り（つまり、cdr）を、まとめて返す。
別々の節に書かれたコードも、書かれた順に1つにまとめられる"
  (apply #'append
	 (mapcar #'rest
		 (remove-if-not
		  (lambda (clause) (eql sym (car clause)))
		  clause-list))))

(defun parse-body-clause (clause)
  "body節をパースする。
もしそれがmatchではじまるリストならば、下の関数で書き換える"
  (case (car clause)
    (match (match-clause-to-sexp clause))
    (t clause)))


(defun match-clause-to-sexp (clause)
  "matchではじまるリストを、match関数の呼び出しに書き換える"
  (destructuring-bind (match-sym regexp . body) clause
    (declare (ignore match-sym))
    `(progn (match ,regexp)
	    (when *matched*
	      ,@body))))


;;; fn-nameという名前の関数を定義するマクロ。
;;; この関数は、関数を1つ受け取り、節で定めた処理を実行していく。
;;; 渡される関数は、引数なしの関数であり、呼び出すとレコードとして
;;; 文字列を返すか、もうレコードが無いことを表すnilを返すべきである。
(defmacro defawk (fn-name binding-clause &rest clause-list)
  ;; まず、適切な節だけを含むか確認する
  (check-clauses clause-list)
  (let ((record-supplier (gensym "RECORD-SUPPLIER"))
	(record (gensym "RECORD"))
	(begin-clause-list (pickup-clauses 'begin clause-list))
	(body-clause-list (pickup-clauses 'body clause-list))
	(end-clause-list (pickup-clauses 'end clause-list)))
    `(defun ,fn-name (,record-supplier)
       (let ,binding-clause
	 (labels (;;; フィールドを参照するための関数。
		  ;;; ($f n) でn番目のフィールドを参照する。
		  ;;; フィールドのカウントは1からはじまる。
		  ;;; ($f 0) はカレントレコードと等しい
		  ($f (n)
		    (cond ((or (not (integerp n))
			       (minusp n)
			       (< *number-of-fields* n))
			   NIL)
			  ((zerop n) *current-record*)
			  (t (nth (- n 1) *current-fields*))))
		  ;;; match節によるマッチの結果を参照するための変数
		  ;;; ($ 0) はマッチした全体を表す文字列を返す
		  ;;; ($ 1) 以降は部分マッチのレジスタを参照する
		  ($ (n)
		    (cond ((or (not (integerp n))
			       (minusp n)
			       (< *number-of-matches* n))
			   NIL)
			  ((zerop n) *matched*)
			  (t (svref *match-list* (- n 1))))))
	   ;; begin節はここに展開される
	   ,@begin-clause-list
	   ;; レコード供給関数がnilを返すまで、body節を繰り返し実行
	   (do ((,record (funcall ,record-supplier)
			 (funcall ,record-supplier)))
	       ((null ,record) nil)
	     (update-record ,record)
	     ,@(mapcar #'parse-body-clause body-clause-list))
	   ;; end節は繰り返しの後に展開される
	   ,@end-clause-list)))))

このように使う

;;; レコードを供給する関数……を生成する関数を定義
;;; この場合は単にファイルから一行ずつ読むだけ。すべて読むと行の代わりにNILを返す。
(defun make-record-supplier (in)
  (lambda ()
    (read-line in NIL)))

;;; 処理を定義。これによってparsing関数が作られる。
(defawk parsing (sum) ; 合計を記録していくための変数 sum を宣言
  (begin (setf sum 0)) ; sum を 0 にしておく。別に宣言時に ((sum 0)) としても同じ事

  ;; \w+ を含むレコードがあればこの節が実行される
  (body
   (match "(\\w+)"
     (format t "MATCH: ~A in ~A~%" ($ 1) ($ 0))))

  ;; すべてのレコードについて、分割されたフィールドとかを表示してみる
  (body
   (format t "RECORD: ~A~%" ($f 0))
   (print *current-fields*)
   (print *number-of-fields*)
   (incf sum (read-from-string ($f 3)))) ; 3番目のフィールドの数字を sum に累積していく

  ;; すべてのレコードを読み終わったら sum の値を表示
  (end (format t "TOTAL: ~A~%" sum)))

;;; レコード供給関数生成関数を parsing 関数に渡してやると処理が始まる
(with-open-file (in "result.txt")
  (parsing (make-record-supplier in)))