Haskell で作る micro Scheme (5)
micro Scheme の続きです。今回はバッククォートの処理を実装して、micro Scheme 用の簡易ライブラリを作成しましょう。なお、今回のプログラムは Haskell ではなく、micro Scheme でのプログラミングになります。Scheme に興味のない方には申し訳ありませんが、あしからずご了承ください。
●バッククオートの動作
バッククオートの処理はマクロで定義したほうが簡単です。拙作のページ Scheme で作る micro Scheme (2) や micro Scheme コンパイラの作成 (2) で作成したバッククォートの処理は簡略版で、 Scheme の仕様書 (R5RS など) には準拠していません。具体的には、バッククォートは入れ子にすることができるのですが、拙作の簡略版では対応していません。今回はちょっと面倒になりますが、バッククォートの入れ子にも対応することにしましょう。
バッククォートの入れ子は、レベルを考えると理解しやすいと思います。一番外側にある `expr0 のレベルを 0 とします。expr0 の中で `expr1 を見つけたら、レベルを +1 します。このとき、` はそのまま出力して、expr1 の処理を行います。その中で ,expr2 や ,@expr2 を見つけた場合、レベルが 0 ならば expr2 を評価するようにマクロ展開し、そうでなければレベルを -1 します。このとき、, や ,@ はそのまま出力して、expr2 の処理を行います。
簡単な例を示しましょう。
gosh> `(a `(b ,(c ,(+ 1 2 3))) ,(car '(d e f))) (a `(b ,(c 6)) d)
リスト A = (a ...) のレベルは 0 です。次の要素が quasiquote なので、リスト B = (b ...) のレベルは 1 になります。リスト B の次の要素は 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> (define a '(1 2 3)) a gosh> `,a (1 2 3) gosh> `,@a => エラー gosh> ``,,@a `(unquote 1 2 3) gosh> ``,@,@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 がない場合に呼び出されます。
quasiquote の実際の処理は関数 translator で行います。引数が ls がリストでその先頭要素がリストの場合は tranlator-list を呼び出します。これはリストの中にある unquote や unquote-splicing を展開します。先頭要素がアトムの場合は tranlator-atom を呼び出します。これは quasiquote の直後にある unquote や unquote-splicing を展開します。それ以外の場合は (quote ls) を生成するコード (list 'quote ls) を出力します。
関数 translator はちょっと複雑な Scheme プログラムになるので、ここでは説明を割愛します。興味のある方は拙作のページ micro Scheme コンパイラの作成 (4) Appendix : バッククォートの修正 をお読みください。
●簡単な実行例
それでは、簡単な実行例を示します。バッククォートの処理はファイル lib.scm に格納されているものとします。
Scm> (load "lib.scm") true Scm> (define a '(1 2 3)) a Scm> `(a b c) (a b c) Scm> `(,a b c) ((1 2 3) b c) Scm> `(,@a b c) (1 2 3 b c)
`(a b c) は a, b, c, をリストに格納するコードにマクロ展開されて、値は (a b c) になります。`(,a b c) は a の値と b, c をリストに格納するコードにマクロ展開されるので、値は ((1 2 3) b c) になります。`(,@a b c) は a の値を append で連結するコードにマクロ展開されるので、値は (1 2 3 b c) になります。
もちろん、unquote と unquote-splicing の引数には関数を与えることもできます。次の例を見てください。
Scm> `(,(car a) b c) (1 b c) Scm> `(,(cdr a) b c) ((2 3) b c) Scm> `(,@(cdr a) b c) (2 3 b c)
`(,(car a) b c) は (car a) が評価されるコードが生成されるので、値は (1 b c) になります。`(,(cdr a) b c) は (cdr a) が評価されるので、値は ((2 3) b c) になります。`(,@(cdr a) b c) は (cdr a) の評価結果を append で連結するので、値は (2 3 b c) になります。
●ライブラリの作成
次は micro Scheme 用のライブラリ lib.scm を作成します。最初は基本的な述語を定義します。
リスト : 述語 ;;; 述語 (define not (lambda (x) (if x false true))) (define null? (lambda (x) (eq? x '()))) (define eqv? eq?) ;;; 数 (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))))
not は引数が真ならば false を、偽ならば true を返します。null? は引数が空リストであれば true を、そうでなければ false を返します。micro Scheme の場合、述語 eqv? と eq? は同じ働きをします。
zero? は数値が 0 または 0.0 の場合は true を返します。positive? は引数が 0 よりも大きい場合に true を返します。negative? は引数が 0 よりも小さい場合に true を返します。even? は引数が偶数であれば true を返します。odd? は引数が奇数であれば true を返します。
簡単な実行例を示します。
Scm> (not true) false Scm> (not false) true Scm> (null? '()) true Scm> (null? '(1)) false Scm> (zero? 0) true Scm> (zero? 1) false Scm> (zero? 0.0) true Scm> (zero? 1.0) false Scm> (positive? 1) true Scm> (positive? 0) false Scm> (positive? -10) false Scm> (negative? -10) true Scm> (negative? 0) false Scm> (negative? 10) false Scm> (even? 1) false Scm> (even? 2) true Scm> (even? 0) true Scm> (odd? 0) false Scm> (odd? 101) true
次は数値に関する処理を行う関数を定義します。
リスト : 数値の関数
(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)))))
abs は引数の絶対値を返します。max は引数の中から最大値を求めます。min は引数の中から最小値を求めます。gcd は引数の最小公倍数を求めます。lcm は引数の最大公約数を求めます。
簡単な実行例を示します。
Scm> (abs -10) 10 Scm> (abs -10.1) 10.1 Scm> (abs 10.1) 10.1 Scm> (abs 10) 10 Scm> (max 1 2) 2 Scm> (min 1 2) 1 Scm> (max 1 2 3 4 5 6 7) 7 Scm> (min 1 2 3 4 5 6 7) 1 Scm> (min 1) 1 Scm> (max 1) 1 Scm> (gcd 24 12) 12 Scm> (gcd 12 128) 4 Scm> (gcd 24 12 128) 4 Scm> (gcd) 0 Scm> (lcmi 7 5) 35 Scm> (lcm 7 5 9) 315 Scm> (lcm) 1
次はリスト操作関数を定義します。
リスト : リスト操作関数
;;; 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 first car)
(define second cadr)
(define third caddr)
(define fourth (lambda (xs) (car (cdddr xs))))
(define fifth (lambda (xs) (cadr (cdddr 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)))))
cxxr と cxxxr は car と cdr の組み合わせた関数です。first, second, ,,, fifth は、リストの先頭要素を 1 番目としたとき、リストの 1, 2, ... 5 番目の要素を取り出します。list は引数をリストに格納して返します。append は引数のリストを連結します。ここでは apply と append-1 を使って、引数のリストをすべて連結するように定義しています。length はリストの長さを求めます。reverse はリストを反転します。list-tail はリスト xs の先頭から k 個の要素を取り除きます。list-ref はリスト xs の k 番目の要素を求めます。
簡単な実行例を示します。
Scm> (list 1 2 3 4 5) (1 2 3 4 5) Scm> (list) () Scm> (append '(a b c) '(d e f)) (a b c d e f) Scm> (append '(a b c) '(d e f) '(1 2 3 4)) (a b c d e f 1 2 3 4) Scm> (append) () Scm> (append '(a b c)) (a b c) Scm> (length '()) 0 Scm> (length '(a b c d e)) 5 Scm> (reverse '()) () Scm> (reverse '(a b c d e)) (e d c b a) Scm> (list-tail '(a b c d e) 0) (a b c d e) Scm> (list-tail '(a b c d e) 1) (b c d e) Scm> (list-tail '(a b c d e) 4) (e) Scm> (list-tail '(a b c d e) 5) () Scm> (list-ref '(a b c d e) 0) a Scm> (list-ref '(a b c d e) 3) d Scm> (list-ref '(a b c d e) 4) e
次はリストの中からデータを探索する関数を定義します。
リスト : リストの探索
(define memq
(lambda (x ls)
(if (null? ls)
false
(if (eq? x (car ls))
ls
(memq x (cdr ls))))))
(define memv
(lambda (x ls)
(if (null? ls)
false
(if (eqv? x (car ls))
ls
(memv x (cdr ls))))))
(define member
(lambda (x ls)
(if (null? ls)
false
(if (equal? x (car ls))
ls
(member x (cdr ls))))))
(define find
(lambda (p xs)
(if (null? xs)
false
(if (p (car xs))
(car xs)
(find p (cdr xs))))))
memq, memv, member はそれぞれ等値の判定に eq?, eqv?, equal? を使います。micro Scheme の場合、eq? と eqv? は同じなので、memq と memv は同じ動作になります。find はリスト xs の中から述語 p が真を返す要素を探します。
簡単な実行例を示します。
Scm> (memq 'c '(a b c d e)) (c d e) Scm> (memq 'f '(a b c d e)) false Scm> (memv 'c '(a b c d e)) (c d e) Scm> (memv 'f '(a b c d e)) false Scm> (memv '(c d) '((a b) (c d) (e f))) false Scm> (member '(c d) '((a b) (c d) (e f))) ((c d) (e f)) Scm> (member '(c e) '((a b) (c d) (e f))) false Scm> (find even? '(1 3 5 6 7)) 6 Scm> (find odd? '(1 3 5 6 7)) 1
次は高階関数を定義します。
リスト : 高階関数
(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))))))
map は map-1 と apply を使って複数のリストを受け取ることができるように定義しています。あとの関数は今まで説明したものと同じです。
簡単な実行例を示します。
Scm> (map (lambda (x) (* x x)) '(1 2 3 4 5)) (1 4 9 16 25) Scm> (map (lambda (x y) (* x y)) '(1 2 3 4 5) '(6 7 8 9 10)) (6 14 24 36 50) Scm> (map (lambda (x y) (cons x y)) '(1 2 3 4 5) '(6 7 8 9 10)) ((1 . 6) (2 . 7) (3 . 8) (4 . 9) (5 . 10)) Scm> (filter even? '(1 2 3 4 5 6 7 8)) (2 4 6 8) Scm> (filter odd? '(1 2 3 4 5 6 7 8)) (1 3 5 7) Scm> (fold-left + 0 '(1 2 3 4 5 6 7 8 9 10)) 55 Scm> (fold-left (lambda (a x) (cons x a)) '() '(1 2 3 4 5 6 7 8 9 10)) (10 9 8 7 6 5 4 3 2 1) Scm> (fold-right + 0 '(1 2 3 4 5 6 7 8 9 10)) 55 Scm> (fold-right cons '() '(1 2 3 4 5 6 7 8 9 10)) (1 2 3 4 5 6 7 8 9 10)
リスト : any と every
(define any
(lambda (p . xs)
(if (memq '() xs)
false
(if (apply p (map car xs))
true
(apply any p (map cdr xs))))))
(define every
(lambda (p . xs)
(if (memq '() xs)
true
(if (apply p (map car xs))
(apply every p (map cdr xs))
false))))
any はリスト xs の要素で述語 p を満たすものが一つでもあれば真を返します。every はリスト xs の要素がすべて述語 p を満たすときに真を返します。なお、any と every は複数のリストを指定することができます。
簡単な実行例を示します。
Scm> (any even? '(1 3 5 6 7 9)) true Scm> (any even? '(1 3 5 7 9)) false Scm> (any < '(1 3 5 7 9) '(2 4 6 8 10)) true Scm> (any < '(2 4 6 8 10) '(1 3 5 7 9)) false Scm> (every even? '(2 4 6 8 10)) true Scm> (every even? '(2 4 6 8 11)) false Scm> (every < '(1 3 5 7 9) '(2 4 6 8 10)) true Scm> (every < '(1 3 5 7 9) '(2 4 6 8 0)) false
●制御構造の実装
次はマクロを使って制御構造を実装します。なお、マクロを使ったプログラムはちょっと難しいので、ここでは制御構造の使い方を説明するだけにとどめます。プログラムの詳しい説明は拙作のページ Scheme による micro Scheme の作成 (2) をお読みください。
●let と let*
最初は局所変数を定義する let を説明します。下図に let の構文を示します。
(let ((変数１ 初期値１)
(変数２ 初期値２)
・・・・・・
(変数Ｍ 初期値Ｍ))
Ｓ式１
・・・・・・
Ｓ式Ｍ)
図 : let の構文
let は関数の仮引数のように与えられた名前を局所変数として扱い、その変数に初期値を評価した値を代入します。そして、後ろに続く S 式を順番に評価します。定義された局所変数は let の実行が終了するまで有効です。let は最後に評価した S 式の値を、let の評価結果として返します。
簡単な実行例を示します。
Scm> (define a 10) a Scm> (define b 20) b Scm> (let ((a 0) (b 1)) (list a b)) (0 1) Scm> a 10 Scm> b 20
最初に define で a に 10 を、b に 20 を代入します。この場合、変数 a, b は大域変数として扱われます。次の let では、a, b を局所変数として定義して 0, 1 を代入します。let の返り値は (list a b) の評価結果になります。返り値は (0 1) なので、a, b は局所変数として扱われていることがわかります。
let* は let とよく似た形式です。局所変数を定義する機能は同じですが、変数の初期化が逐次的に行われるところが異なります。let* を使うと、先に初期化された変数の値をあとから参照することができます。
簡単な実行例を示します。
Scm> (let* ((a 1) (b (+ a 1))) (list a b)) (1 2) Scm> (let* ((a 1) (b (+ a 1)) (c (* b 2))) (list a b c)) (1 2 4)
●and と or
次は論理演算子 and と or を説明します。
(and Ｓ式１ Ｓ式２ Ｓ式３ Ｓ式４ ..... ) (or Ｓ式１ Ｓ式２ Ｓ式３ Ｓ式４ ..... )
and は複数の述語を「～かつ～」で結ぶ働きをします。and は与えられた S 式を左から順番に評価します。そして、S 式の評価結果が false であれば、残りの S 式を評価せずに false を返します。ただし、最後まで S 式が false に評価されなかった場合は、いちばん最後の S 式の評価結果を返します。
or は複数の述語を「～または～」で結ぶ働きをします。or は and と違い、S 式の評価結果が false 以外の場合に、残りの S 式を評価せずにその評価結果を返します。すべての S 式が false に評価された場合は false を返します。
簡単な実行例を示します。
Scm> (and 1 2 3 4 5) 5 Scm> (and 1 2 false 4 5) false Scm> (or 1 2 3) 1 Scm> (or false 2 3) 2 Scm> (or false false 3) 3 Scm> (or false false false) false
●letrec
Scheme には局所的な関数を定義するシンタックス形式 letrec と名前付き let (named let) が用意されています。とくに、末尾再帰は名前付き let を使うと簡単にプログラムすることができます。
letrec の構文を下図に示します。
(letrec
((var1 value1)
(var2 value2)
.....)
body)
図 : letrec の構文
letrec は let と同じ構文ですが、変数名 var を値 value の中で参照できるところが異なります。したがって、変数 var の値 value がラムダ式の場合、その中で自分自身を呼び出すことができる、つまり再帰定義が可能というわけです。
簡単な例として、letrec を使って階乗を計算する関数 fact を作りましょう。
リスト : 階乗
(define fact
(lambda (x)
(letrec ((iter
(lambda (n a)
(if (zero? n)
a
(iter (- n 1) (* a n))))))
(iter x 1))))
実際の処理は局所関数 iter で行います。iter は末尾再帰で、引数 a を累積変数として使っています。
Scm> (fact 9) 362880 Scm> (fact 10) 3628800 Scm> (fact 11) 39916800
名前付き let はその名が示すように let に名前を付けたものです。名前付き let の構文を示します。
(let 名前
((変数１ 初期値１)
(変数２ 初期値２)
・・・・・・
(変数Ｍ 初期値Ｍ))
Ｓ式１
・・・・・・
Ｓ式Ｍ
(名前 引数１ ... 引数Ｍ))
図 : 名前付き let の構文
名前付き let は、let の後ろに名前を指定します。この名前が関数名になると考えてください。その後ろに定義される変数がその関数の引数になり、let の中の S 式がその関数の処理内容になります。そして、let の中でその関数を呼び出すことができ、let の最後で再帰呼び出しを行えば末尾再帰になります。
簡単な例を示しましょう。次のリスト見てください。
リスト : 名前付き let の使用例
;;; フィボナッチ関数
(define fibo
(lambda (n)
(let loop ((n n) (a 1) (b 0))
(if (zero? n)
a
(loop (- n 1) (+ a b) a)))))
fibo の定義 (let loop ((n n) (a 1) (b 0)) のように、変数と初期値の指定に同じ名前 n を使っていますが、前の n は let の中で有効な変数名になり、後ろの n は引数の n で初期値になります。この場合、let の変数 n が引数 n を隠蔽することになるので、let の中から引数 n の値にアクセスすることはできなくなります。ご注意ください。
Scm> (fibo 5) 8 Scm> (fibo 10) 89 Scm> (fibo 15) 987 Scm> (fibo 20) 10946 Scm> (fibo 50) 20365011074
●begin
begin は引数の S 式を順番に評価して、最後に評価した S 式の結果を返します。つまり、ラムダ式の本体と同じ動作をします。
簡単な実行例を示します。
Scm> (begin 1 2 3 4 5) 5 Scm> (define a 10) a Scm> (begin 1 2 3 4 a) 10
●cond
複雑な条件分岐は if を入れ子にすることで表すことができますが、Scheme (Lisp) にはもっと便利な cond が用意されています。cond はちょっと奇妙な構文をもっています。
(cond ( 条件部Ａ Ｓ式A1 Ｓ式A2 ... )
( 条件部Ｂ Ｓ式B1 Ｓ式B2 ... )
・・・・・
( 条件部Ｍ Ｓ式M1 Ｓ式M2 ... )
( else Ｓ式Z1 Ｓ式Z2 ... ))
図 : cond の構造
cond は複数の節 (リスト) を引数として受け取ります。各節の先頭には条件をチェックする述語があり、条件が成立した場合、残りの S 式を評価します。条件が不成立であれば、次の節に移ります。
たとえば、条件部 A が不成立であれば、次の節の条件部 B をチェックします。条件が成立したならば、同じ節にある S 式を順番に評価していきます。そして、いちばん最後に評価された S 式の評価結果が cond の返り値となります。したがって、一度節が選択されたら、それ以降の節は評価されません。
もしも、どの条件部も不成立であれば、cond の返り値は未定義です。Gauche では #<undef> を返します。ところで、上図ではいちばん最後の節で条件部が else になっていますね。この節は無条件で実行されます。つまり、条件部 A から条件部 M までのすべての条件が不成立でも、最後の節が必ず選択されるのです。このように、cond を使う場合は最後の節の条件部を else にしておくことを好むプログラマが多いようです。
cond の処理を図に表すと次のようになります。
簡単なプログラムとその実行例を示します。
リスト : cond の使用例
(define cond-test
(lambda (x)
(cond ((eq? x 'a) 1)
((eq? x 'b) 2)
((eq? x 'c) 3)
(else 0))))
Scm> (cond-test 'a) 1 Scm> (cond-test 'b) 2 Scm> (cond-test 'c) 3 Scm> (cond-test 'd) 0
●case
case は cond と同様に条件分岐を行うときに使います。case は cond より奇妙な構文をもっています。
(case キーとなるＳ式
( キーリスト１ Ｓ式A1 Ｓ式A2 ... )
( キーリスト２ Ｓ式B1 Ｓ式B2 ... )
・・・・・
( キーリストＭ Ｓ式M1 Ｓ式M2 ... )
( else Ｓ式T1 Ｓ式T2 ... ))
図 : case の構文
case は最初にキーとなる S 式を受け取り、そのあと cond と同様に複数の節が続きます。cond には節の先頭に条件部がありましたが、case の場合はキーリストというものがあります。まず、キーとなる S 式を評価します。次に、この評価結果とキーリストに格納された要素を比較します。このとき、キーリスト本体や要素は評価されないことに注意してください。もし、等しいキーを見つけた場合は、その節の S 式を順番に実行します。
上図を見てください。case ではキーがキーリストの中に含まれているかチェックします。データの比較には述語 eqv? が適用されます。等しいキーを発見したら、その後ろの S 式を順番に実行していきます。
簡単なプログラムとその実行例を示します。
リスト : case の使用例
(define case-test
(lambda (x)
(case x
((a b c) 1)
((d e f) 2)
((g h i) 3)
(else 0))))
Scm> (case-test 'a) 1 Scm> (case-test 'e) 2 Scm> (case-test 'i) 3 Scm> (case-test 'j) 0
●do
do は繰り返しを表します。do の構文は少々複雑です。
(do ((var init-form [step-form]) ...) (end-test [result ...]) Ｓ式 ... )
- 変数 var を init-form の評価結果に初期化します。
- end-test を評価し、結果が真であれば繰り返しを終了します。ここで result を評価します。result は複数の S 式を指定することができ、最後の S 式の評価結果が do の返り値になります。result が省略された場合、Gauche は #t を返します。
- 本体の S 式を順番に評価します。
- 変数 var の値を step-form の評価結果に更新します。step-form がない場合は何もしません。
- 2 から 4 までを繰り返します。
変数 var はレキシカル変数として扱われます。do の処理を図に表すと次のようになります。
図 : do の処理
ここで Scheme の do は変数 var を更新するときに破壊的な操作は行っていないことに注意してください。つまり、do は名前付き let のように、繰り返しを再帰定義で実現しています。
do はＣ言語の for 文とよく似ています (実際は FORTRAN の do ループの影響を受けたと思われます)。ただし、Ｃ言語では end-test が真の間は繰り返しを続けるのですが、Scheme の do は end-test が真になると繰り返しを終了します。繰り返しを続ける条件が逆になっているので注意して下さい。
それでは簡単な使用例を示しましょう。
リスト : do の使用例
(define fact-do (lambda (x)
(do ((n 1 (+ n 1)) (result 1)) ; 変数の定義
((> n x) result) ; end-test と result
(set! result (* result n))))) ; 繰り返す S 式
do を使って階乗を計算します。1 から x までを順番に乗算します。n と result がレキシカル変数です。変数 n は 1 に初期化されます。そして、繰り返すたびに step-form の (+ n 1) が評価され、n の値がひとつ増えます。result は 1 に初期化されますが、step-form は省略されています。(> n x) が終了条件で、result の評価結果が do の返り値になります。(> n 1) の評価値が真になると、繰り返しを終了して result の値を返します。
Scm> (fact-do 9) 362880 Scm> (fact-do 10) 3628800 Scm> (fact-do 11) 39916800
●プログラムリスト
;;;
;;; lib.scm : micro Scheme 用簡易ライブラリ
;;;
;;; Copyright (C) 2013-2021 Makoto Hiroi
;;;
;;; 述語
(define not (lambda (x) (if x false true)))
(define null? (lambda (x) (eq? x '())))
(define eqv? eq?)
;;; 数
(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 first car)
(define second cadr)
(define third caddr)
(define fourth (lambda (xs) (car (cdddr xs))))
(define fifth (lambda (xs) (cadr (cdddr 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)
false
(if (eq? x (car ls))
ls
(memq x (cdr ls))))))
(define memv
(lambda (x ls)
(if (null? ls)
false
(if (eqv? x (car ls))
ls
(memv x (cdr ls))))))
(define member
(lambda (x ls)
(if (null? ls)
false
(if (equal? x (car ls))
ls
(member x (cdr ls))))))
(define find
(lambda (p xs)
(if (null? xs)
false
(if (p (car xs))
(car xs)
(find p (cdr xs))))))
;;;
;;; 高階関数
;;;
(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))))))
;;; any と every
(define any
(lambda (p . xs)
(if (memq '() xs)
false
(if (apply p (map car xs))
true
(apply any p (map cdr xs))))))
(define every
(lambda (p . xs)
(if (memq '() xs)
true
(if (apply p (map car xs))
(apply every p (map cdr xs))
false))))
;;
;; マクロ
;;
(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)
true
(if (null? (cdr args))
(car args)
`(if ,(car args) (and ,@(cdr args)) false)))))
;;; or
(define-macro or
(lambda args
(if (null? args)
false
(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)))))
改訂 2021 年 8 月 1 日