2009年7月16日木曜日

リーダマクロでドット区切りなメソッド呼び出し風な何か

酔った勢いでリーダマクロを書いた.
(foo bar piyo)をbar.foo(piyo)と書けるようにしてみた.
次の朝にはコードを理解できない可能性が高い.

(defun dot-reader (stream ch1 ch2)
(declare (ignore ch1 ch2))
(cons
'progn
(merge-method-invokation-sexp
(convert-to-method-invokation
(mapcar
#'convert-to-dot-exp
(read-delimited-list #\] stream))))))


(defun convert-to-dot-exp (sexp)
(cond
((listp sexp)
(mapcar #'convert-to-dot-exp sexp))
((symbolp sexp)
(convert-symbol-to-dot-exp sexp))
(t sexp)))

(defun merge-method-invokation-sexp (sexp &optional prev)
(if (null sexp)
;;終端
(if prev (list prev) nil)
(let ((fst (car sexp)))
(if (listp fst)
(case (car fst)
(:method-invoke
(append
(if prev (list prev) nil)
(merge-method-invokation-sexp
(cdr sexp)
`(,(third fst)
,(second fst)
,@(nthcdr 3 fst)))))
(:dot
(merge-method-invokation-sexp
(cdr sexp)
`(,(second fst)
,prev
,@(nthcdr 2 fst)) ))
(t
(append
(if prev (list prev) nil)
(merge-method-invokation-sexp
(cdr sexp)
fst))))
(append
(if prev (list prev) nil)
(merge-method-invokation-sexp
(cdr sexp)
fst))))))

(defun convert-to-method-invokation (sexp)
(if (not (listp sexp)) sexp
(loop
:for rest = sexp then (if (and (listp o)
(or (eq (car o) :dot)
(eq (car o) :method-invoke)))
(cddr rest)
(cdr rest))
:for o = (car rest)
:while rest
:collect
(if (and (listp o)
(or (eq (car o) :dot)
(eq (car o) :method-invoke)))
(append o (second rest))
o))))

(defun convert-symbol-to-dot-exp (sym)
(let ((str (symbol-name sym)))
(let ((pos (position #\. str)))
(if (not pos)
sym
(if (= pos 0)
(list :dot
(convert-symbol-to-dot-exp
(intern (subseq str 1))))
(list
:method-invoke
(read-from-string (subseq str 0 pos))
(convert-symbol-to-dot-exp
(intern (subseq str (1+ pos))))))))))

(set-macro-character #\] (get-macro-character #\)))
(set-dispatch-macro-character #\# #\[ 'dot-reader)

なんとなく動くひどいコード.
酔ってなくてもこのくらいしか書けないレベルですが.
目が覚めて気になったら書きなおそう.

以下実行結果.

>#[(loop :for i from 0 to 10 :collect i).elt(1)]
1
>#[(defparameter a #\0) a.char-code().+(9).code-char()]
#\9

0 件のコメント:

コメントを投稿