拙作のページ「Scheme で作る micro Scheme (2)」や「micro Scheme コンパイラの作成 (2)」で作成したバッククォートの処理は簡略版で、 Scheme の仕様書 (R5RS など) に準拠しておりません。具体的には、バッククォートは入れ子にすることができるのですが、拙作の簡略版では対応していません。今回はちょっと複雑になりますが、バッククォートの入れ子にも対応するようにプログラムを修正しましょう。
バッククォートの入れ子は、レベルを考えると理解しやすいと思います。一番外側にある `expr0 をレベルを 0 とします。expr0 の中で `expr1 を見つけたら、レベルを +1 します。このとき、` はそのまま出力して、expr1 の処理を行います。その中で ,expr2 や ,@expr2 を見つけた場合、レベルが 0 ならば expr2 を評価するようにマクロ展開し、そうでなければレベルを -1 します。このとき、, や ,@ はそのまま出力して、expr2 の処理を行います。
簡単な例を示しましょう。
gosh[r7rs.user]> `(a `(b ,(c ,(+ 1 2 3))) ,(car '(d e f))) (a `(b ,(c 6)) d)
リスト A = (a ...) のレベルは 0 です。次の要素が quasiquote なので、リスト B = (b ...) のレベルは 1 になります。リスト B の 2 番目の要素は unquote ですが、レベルが 1 なので、unquote をそのまま出力して、リスト C = (c ,(+ 1 2 3)) を処理します。このとき、レベルは -1 されて 0 になります。リスト C の中の unquote はレベルが 0 なので、(+ 1 2 3) を評価して 6 になります。リスト A の最後の要素はレベル 0 の unquote なので (car '(d e f)) を評価して d になります。
バッククォートはリストだけではなくアトムにも適用することができます。拙作の簡略版はこの処理にも対応していません。次の例を見てください。
gosh[r7rs.user]> (define a '(1 2 3)) a gosh[r7rs.user]> `,a (1 2 3) gosh[r7rs.user]> `,@a => エラー gosh[r7rs.user]> ``,@,@a `(unquote-splicing 1 2 3)
`,a は (1 2 3) に展開されますが、`,@a はリストを外せないのでエラーになります。ただし、unquote-splicing の前に unquote や unquote-splicing がそのまま展開される場合は、リストを外すことができるのでエラーにはならないようです。
それではプログラムを作りましょう。
リスト : バッククオートの処理
(define unquote
(lambda (x) (error "unquote appeared outside quasiquote")))
(define unquote-splicing
(lambda (x) (error "unquote-splicing appeared outside quasiquote")))
(define translator
(lambda (ls n)
(if (pair? ls)
(if (pair? (car ls))
(translator-list ls n)
(translator-atom ls n))
(list 'quote ls))))
(define-macro quasiquote (lambda (x) (translator x 0)))
関数 unquote と unquote-splicing はエラーを返します。これは `,,a のように、対応する quasiquote がない場合に呼び出されます。micro Scheme コンパイラ (secd.scm) に primitive の関数 error を追加してください。
リスト : secd.scm の修正
(define *global-environment*
(list
・・・ 省略 ・・・
(list 'error 'primitive error) ; 追加
))
quasiquote の実際の処理は関数 translator で行います。引数が ls がリストでその先頭要素がリストの場合は tranlator-list を呼び出します。これはリストの中にある unquote や unquote-splicing を展開します。先頭要素がアトムの場合は tranlator-atom を呼び出します。これは quasiquote の直後にある unquote や unquote-splicing を展開します。それ以外の場合は (quote ls) を生成するコード (list 'quote ls) を出力します。
次は translator-list を作ります。
リスト : バッククオートの処理 (2)
(define translator-list
(lambda (ls n)
(if (eq? (caar ls) 'unquote)
(translator-unquote ls n)
(if (eq? (caar ls) 'unquote-splicing)
(translator-unquote-splicing ls n)
(if (eq? (caar ls) 'quasiquote)
(translator-quasiquote ls n)
(list 'cons
(translator (car ls) n)
(translator (cdr ls) n)))))))
translator-list は (caar ls) の種類によって処理を振り分けるだけです。unquote であれば translator-unquote を、unquote-splicing であれば translator-unquote-splicing を、quasiquote であれば translator-quasiquote を呼び出します。それ以外の場合は (car ls) と (cdr ls) に対して translator を適用し、その結果を cons で連結するコードを生成します。
次は unquote を展開する translator-unquote を作ります。
リスト : バッククオートの処理 (3)
(define translator-sub
(lambda (sym ls n succ)
(list 'list
(list 'quote sym)
(translator ls (+ n succ)))))
(define translator-unquote
(lambda (ls n)
(list 'cons
(if (zero? n)
(cadar ls)
(translator-sub 'unquote (cadar ls) n -1))
(translator (cdr ls) n))))
レベル n が 0 の場合、unquote の次の要素 (cadar ls) を評価するコードを生成します。これは (cadar ls) をそのまま出力するだけです。そうでなければ、unquote をそのまま出力して、(cadar ls) の中を調べます。この処理を関数 translator-sub で行います。このときレベルを -1 します。あとは、(cdr ls) に traslator を適用して、2 つの引数を cons で連結するコードを生成します。
次は unquote-splicing を展開する関数 translator-unquote-splicing を作ります。
リスト : バッククオートの処理 (4)
(define translator-unquote-splicing
(lambda (ls n)
(if (zero? n)
(list 'append (cadar ls) (translator (cdr ls) n))
(list 'cons
(translator-sub 'unquote-splicing (cadar ls) n -1)
(translator (cdr ls) n)))))
レベル n が 0 の場合は、(cadar ls) を評価した結果と (cdr ls) に translator を適用した結果を append するコードを生成します。これで (cadar ls) の評価結果のリストを外すことができます。そうでなければ、translator-sub で unquote-splicing をそのまま出力するコードを生成し、(cdr ls) に translator を適用した結果と cons するコードを生成します。translator-sub を呼び出すときはレベルを -1 することをお忘れなく。
次は quasiquote をそのまま出力する関数 translator-quasiquote を作ります。
リスト : バッククオートの処理 (5)
(define translator-quasiquote
(lambda (ls n)
(list 'cons
(translator-sub 'quasiquote (cadar ls) n 1)
(translator (cdr ls) n))))
translator-quasiquote は簡単です。translator-sub で quasiquote をそのまま出力するコードを生成し、(cdr ls) に translator を適用した結果と cons するコードを生成します。translator-sub を呼び出すときはレベルを +1 することに注意してください。
最後に translator-atom を作ります。
リスト : バッククオートの処理 (6)
(define translator-atom
(lambda (ls n)
(if (eq? (car ls) 'unquote)
(if (zero? n)
(cadr ls)
(if (= n 1)
(if (eq? (car (cadr ls)) 'unquote-splicing)
(list 'cons (list 'quote 'unquote) (cadr (cadr ls)))
(translator-sub 'unquote (cadr ls) n -1))
(translator-sub 'unquote (cadr ls) n -1)))
(if (eq? (car ls) 'unquote-splicing)
(if (zero? n)
(error "invalid unquote-splicing form")
(if (= n 1)
(if (eq? (car (cadr ls)) 'unquote-splicing)
(list 'cons (list 'quote 'unquote-splicing) (cadr (cadr ls)))
(translator-sub 'unquote-splicing (cadr ls) n -1))
(translator-sub 'unquote-splicing (cadr ls) n -1)))
(if (eq? (car ls) 'quasiquote)
(translator-sub 'quasiquote (cadr ls) n 1)
(list 'cons
(list 'quote (car ls))
(translator (cdr ls) n)))))))
(car ls) が unquote でレベル n が 0 の場合、(cadr ls) をそのまま出力します。これでマクロ展開されたあと (cadr ls) が評価されます。レベル n が 1 で、(cadr ls) の先頭要素が unquote-splicing の場合、次の要素 (cadr (cadr ls)) を評価して、そのリストの先頭に unquote を cons で追加するコードを生成します。それ以外の場合は、translator-sub で unquote をそのまま出力するコードを生成します。
(car ls) が unquote-splicing でレベル n が 0 の場合、リストを外せないのでエラーを返します。レベル n が 1 で、(cadr ls) の先頭要素が unquote-splicing の場合、次の要素 (cadr (cadr ls)) を評価して、そのリストの先頭に unquote-splicing を cons で追加するコードを生成します。それ以外の場合は、translator-sub で unquote-splicing をそのまま出力するコードを生成します。
(car ls) を quasiquote の場合は translator-sub で quasiquote をそのまま出力するコードを生成します。それ以外の場合は (car ls) をそのまま出力するコードを生成し、(cdr ls) に translator-sub を適用したコードと cons するコードを生成します。
それでは実際に試してみましょう。必要なプログラムはファイル lib.scm に格納されているものとします。
>>> (define a 1) a >>> (define b '(a b c)) b >>> `(a b) (a b) >>> `(,a ,b) (1 (a b c)) >>> `(,a ,@b) (1 a b c) >>> `(a `(b ,(c ,(+ 1 2 3))) ,(car '(d e f))) (a `(b ,(c 6)) d) >>> `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) (a `(b ,(+ 1 2) ,(foo 4 d) e) f) >>> (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)) (a `(b ,x ,'y d) e) >>> `,a 1 >>> `,b (a b c) >>> ``,,a `,1 >>> ``,,b `,(a b c) >>> ``,@,@b `(unquote-splicing a b c) >>> ,a ERROR: unquote appeared outside quasiquote >>> ,@b ERROR: unquote-splicing appeared outside quasiquote >>> `,@b ERROR: invalid unquote-splicing form >>> `,,@b ERROR: unquote-splicing appeared outside quasiquote >>> `,,a ERROR: unquote appeared outside quasiquote
基本的な機能は正常に動作しているようですが、まだまだ不具合が残っているかもしれません。興味のある方はいろいろ試してみてください。
;;;
;;; lib.scm : micro Scheme 用簡易ライブラリ
;;;
;;; Copyright (C) 2013-2021 Makoto Hiroi
;;;
;;; 述語
(define not (lambda (x) (if x #f #t)))
(define null? (lambda (x) (eq? x ())))
;;; 数
(define zero? (lambda (x) (= x 0)))
(define positive? (lambda (x) (< 0 x)))
(define negative? (lambda (x) (> 0 x)))
(define even? (lambda (x) (zero? (mod x 2))))
(define odd? (lambda (x) (not (even? x))))
(define abs (lambda (x) (if (negative? x) (- x) x)))
(define max
(lambda (x . xs)
(fold-left (lambda (a b) (if (< a b) b a)) x xs)))
(define min
(lambda (x . xs)
(fold-left (lambda (a b) (if (> a b) b a)) x xs)))
(define gcdi
(lambda (a b)
(if (zero? b)
a
(gcdi b (mod a b)))))
(define gcd
(lambda xs
(if (null? xs)
0
(fold-left (lambda (a b) (gcdi a b)) (car xs) (cdr xs)))))
(define lcmi (lambda (a b) (/ (* a b) (gcdi a b))))
(define lcm
(lambda xs
(if (null? xs)
1
(fold-left (lambda (a b) (lcmi a b)) (car xs) (cdr xs)))))
;;; cxxr
(define caar (lambda (xs) (car (car xs))))
(define cadr (lambda (xs) (car (cdr xs))))
(define cdar (lambda (xs) (cdr (car xs))))
(define cddr (lambda (xs) (cdr (cdr xs))))
;;; cxxxr
(define caaar (lambda (xs) (car (caar xs))))
(define caadr (lambda (xs) (car (cadr xs))))
(define cadar (lambda (xs) (car (cdar xs))))
(define caddr (lambda (xs) (car (cddr xs))))
(define cdaar (lambda (xs) (cdr (caar xs))))
(define cdadr (lambda (xs) (cdr (cadr xs))))
(define cddar (lambda (xs) (cdr (cdar xs))))
(define cdddr (lambda (xs) (cdr (cddr xs))))
;;;
;;; リスト操作
;;;
(define list (lambda x x))
(define append-1
(lambda (xs ys)
(if (null? xs)
ys
(cons (car xs) (append-1 (cdr xs) ys)))))
(define append
(lambda xs
(if (null? xs)
'()
(if (null? (cdr xs))
(car xs)
(append-1 (car xs) (apply append (cdr xs)))))))
(define length
(lambda (xs)
(fold-left (lambda (a x) (+ a 1)) 0 xs)))
(define reverse
(lambda (xs)
(fold-left (lambda (a x) (cons x a)) () xs)))
(define list-tail
(lambda (xs k)
(if (zero? k)
xs
(list-tail (cdr xs) (- k 1)))))
(define list-ref
(lambda (xs k)
(if (zero? k)
(car xs)
(list-ref (cdr xs) (- k 1)))))
;;; リストの探索
(define memq
(lambda (x ls)
(if (null? ls)
#f
(if (eq? x (car ls))
ls
(memq x (cdr ls))))))
(define memv
(lambda (x ls)
(if (null? ls)
#f
(if (eqv? x (car ls))
ls
(memv x (cdr ls))))))
(define member
(lambda (x ls)
(if (null? ls)
#f
(if (equal? x (car ls))
ls
(member x (cdr ls))))))
;;;
;;; 高階関数
;;;
(define map-1
(lambda (f xs)
(if (null? xs)
()
(cons (f (car xs)) (map f (cdr xs))))))
(define map
(lambda (f . args)
(if (memq '() args)
'()
(cons (apply f (map-1 car args))
(apply map f (map-1 cdr args))))))
(define filter
(lambda (p xs)
(if (null? xs)
()
(if (p (car xs))
(cons (car xs) (filter p (cdr xs)))
(filter p (cdr xs))))))
(define fold-left
(lambda (f a xs)
(if (null? xs)
a
(fold-left f (f a (car xs)) (cdr xs)))))
(define fold-right
(lambda (f a xs)
(if (null? xs)
a
(f (car xs) (fold-right f a (cdr xs))))))
;;;
;;; マクロ
;;;
(define unquote
(lambda (x) (error "unquote appeared outside quasiquote")))
(define unquote-splicing
(lambda (x) (error "unquote-splicing appeared outside quasiquote")))
(define translator-sub
(lambda (sym ls n succ)
(list 'list
(list 'quote sym)
(translator ls (+ n succ)))))
(define translator-unquote
(lambda (ls n)
(list 'cons
(if (zero? n)
(cadar ls)
(translator-sub 'unquote (cadar ls) n -1))
(translator (cdr ls) n))))
(define translator-unquote-splicing
(lambda (ls n)
(if (zero? n)
(list 'append (cadar ls) (translator (cdr ls) n))
(list 'cons
(translator-sub 'unquote-splicing (cadar ls) n -1)
(translator (cdr ls) n)))))
(define translator-quasiquote
(lambda (ls n)
(list 'cons
(translator-sub 'quasiquote (cadar ls) n 1)
(translator (cdr ls) n))))
(define translator-list
(lambda (ls n)
(if (eq? (caar ls) 'unquote)
(translator-unquote ls n)
(if (eq? (caar ls) 'unquote-splicing)
(translator-unquote-splicing ls n)
(if (eq? (caar ls) 'quasiquote)
(translator-quasiquote ls n)
(list 'cons
(translator (car ls) n)
(translator (cdr ls) n)))))))
(define translator-atom
(lambda (ls n)
(if (eq? (car ls) 'unquote)
(if (zero? n)
(cadr ls)
(if (= n 1)
(if (eq? (car (cadr ls)) 'unquote-splicing)
(list 'cons (list 'quote 'unquote) (cadr (cadr ls)))
(translator-sub 'unquote (cadr ls) n -1))
(translator-sub 'unquote (cadr ls) n -1)))
(if (eq? (car ls) 'unquote-splicing)
(if (zero? n)
(error "invalid unquote-splicing form")
(if (= n 1)
(if (eq? (car (cadr ls)) 'unquote-splicing)
(list 'cons (list 'quote 'unquote-splicing) (cadr (cadr ls)))
(translator-sub 'unquote-splicing (cadr ls) n -1))
(translator-sub 'unquote-splicing (cadr ls) n -1)))
(if (eq? (car ls) 'quasiquote)
(translator-sub 'quasiquote (cadr ls) n 1)
(list 'cons
(list 'quote (car ls))
(translator (cdr ls) n)))))))
(define translator
(lambda (ls n)
(if (pair? ls)
(if (pair? (car ls))
(translator-list ls n)
(translator-atom ls n))
(list 'quote ls))))
(define-macro quasiquote (lambda (x) (translator x 0)))
;;; let (named-let)
(define-macro let
(lambda (args . body)
(if (pair? args)
`((lambda ,(map car args) ,@body) ,@(map cadr args))
; named-let
`(letrec ((,args (lambda ,(map car (car body)) ,@(cdr body))))
(,args ,@(map cadr (car body)))))))
;;; and
(define-macro and
(lambda args
(if (null? args)
#t
(if (null? (cdr args))
(car args)
`(if ,(car args) (and ,@(cdr args)) #f)))))
;;; or
(define-macro or
(lambda args
(if (null? args)
#f
(if (null? (cdr args))
(car args)
`(let ((+value+ ,(car args)))
(if +value+ +value+ (or ,@(cdr args))))))))
;;; let*
(define-macro let*
(lambda (args . body)
(if (null? (cdr args))
`(let (,(car args)) ,@body)
`(let (,(car args)) (let* ,(cdr args) ,@body)))))
;;; letrec
(define-macro letrec
(lambda (args . body)
(let ((vars (map car args))
(vals (map cadr args)))
`(let ,(map (lambda (x) `(,x '*undef*)) vars)
,@(map (lambda (x y) `(set! ,x ,y)) vars vals)
,@body))))
;;; begin
(define-macro begin
(lambda args
(if (null? args)
`((lambda () '*undef*))
`((lambda () ,@args)))))
;;; cond
(define-macro cond
(lambda args
(if (null? args)
'*undef*
(if (eq? (caar args) 'else)
`(begin ,@(cdar args))
(if (null? (cdar args))
(caar args)
`(if ,(caar args)
(begin ,@(cdar args))
(cond ,@(cdr args))))))))
;;; case
(define-macro case
(lambda (key . args)
(if (null? args)
'*undef*
(if (eq? (caar args) 'else)
`(begin ,@(cdar args))
`(if (memv ,key ',(caar args))
(begin ,@(cdar args))
(case ,key ,@(cdr args)))))))
;;; do
(define-macro do
(lambda (var-form test-form . args)
(let ((vars (map car var-form))
(vals (map cadr var-form))
(step (map cddr var-form)))
`(letrec ((loop (lambda ,vars
(if ,(car test-form)
(begin ,@(cdr test-form))
(begin
,@args
(loop ,@(map (lambda (x y)
(if (null? x) y (car x)))
step
vars)))))))
(loop ,@vals)))))