SRFI1 Constructorsを眺めたぞ。
srfi1のリストを生成するやつら。
以下は、てきとーにドキュメント眺めてまとめたもの。
cons,list,make-list,list-copyらはr7rsに含まれているので無視する。
xcons
第二引数をcar部に、第一引数をcdr部にconsセルを生成する。
例
(xcons 1 2) ;(2 . 1)
cons*
引数の最後が末尾cdr部になるリストを生成する。
(cons* a1 a2 … an-1 an) => (a1 a2 … an-1 . an)
例
(cons* 1 2 3 4) ;(1 2 3 . 4)
list-tabulate
0〜n-1のそれぞれに、初期化関数を適用したリストを返す。
例
(list-tabulate 5 (lambda (n) (* n n ) ) ) ;(0 1 4 9 16)
circular-list
与えた引数を繰り返す循環リストを生成する。
例
(circular-list 1 2 3 4) ;#0=(1 2 3 4 . #0#)
iota
個数、初期値、増加値を指定して、数値のリストを生成する。
例(個数5 初期値 0 増加値 1の場合)
(iota 5 0 1) (0 1 2 3 4)
Whitespaceを使ったぞ。
Whitespaceは、esolangの一つで、[space]、[tab]、改行だけでスタックマシン的な命令を表現する言語。
チュートリアル。
これが割とあっさりしてるので、動作確認用に書いたコードをメモとして貼ることにする。
[space]はS、[tab]はT、改行はLとして表記する。
stdinで数字を読んで、stdoutで出力する。
数字をechoするだけ。
SSSL SL STL TTTTTTL STL L L
SSSLで、0をstackにpushする。
SLSで、stackトップを複製する。つまりstackの中身は、[0,0]。
TLTTで、数値を標準入力で読み込んで、stackトップの値のアドレスに入れる。stackトップをpopする。
TTTで、stackからアドレスを取り出して、そのアドレスにあるヒープのデータをstackにpushする。
TLSTでstackトップの値を数値として標準出力する。stackトップをpopする。
LLLでプログラム終了。
3+2をして標準出力する
SSSTTL SSSTSL TSSSTL STL L L
SSSTTL、3をstackにpush。
SSSTSL、2をstackにpush。
TSSS、stackから2つ取り出し、加算結果をstackに積む。
TLST、stackから1つ取り出し、数値として標準出力する。
LLLでプログラム終了
long jump
L SL STTSSSSTL SSSL TL STL SSSTTSSSSTL SSSTL TL STL L L
LSLSTTSSSSTL、ラベルaにジャンプする。(STTSSSST=‘a’)
SSSL、0をstackにpush。(実行されない)
TLSTL、標準出力(実行されない)
LSSSTTSSSSTL、ラベルaを定義する。
SSSTL、1をstackにpush。
TLST、標準出力。
LLL、プログラム終了。
サブルーチン
L SL STTSSSSTL L SSSTTSSSTSL SSSTL TL STL TL L SSSTTSSSSTL L STSTTSSSTSL L L
LSLSTTSSSSTL、ラベル'a'にロングジャンプ。
LSSSTTSSSTSL、ラベル'b'を定義
SSSTL、1をstackに積む
TLST、数値として標準出力
LTL、サブルーチンを抜けてreturnする。
LSSSTTSSSSTL、ラベル'a'を定義。
LSTSTTSSSTSL、サブルーチンとしてラベル'b'にジャンプ
LLL、プログラム終了。
入力した値が0ならば'y'をそれ以外なら'x'を標準出力する
条件分岐。
SSSL SL STL TTTTTL TSSTTSSSSTL SSSTTTTSSSL TL SSL SL STTSSSTSL L SSSTTSSSSTL SSSTTTTSSTL TL SSL SSSTTSSSTSL L L L
SSSL、0をstackに積む
SLS、stackトップを複製
TLTT、標準入力結果をstackトップが示すアドレスに入れる。
TTT、stackトップが示すアドレスのデータをstackトップにpushする。
LTSSTTSSSSTL、stackトップの値が0ならばラベル'a'に飛ぶ。
SSSTTTTSSSL、120(‘x’)をstackに積む。
TLSS、stackトップをcharとして出力する。
LSLSTTSSSTSL、ラベル'b'に飛ぶ。
LSSSTTSSSSTL、ラベル'a'を定義する。
SSSTTTTSSTL、121(‘y’)をstackに積む。
TLSS、stackトップをcharとして出力する。
LSSSTTSSSTSL、ラベルbを定義する。
LLLプログラム終了
GraphVizを使ったぞ。
GraphVizは、dot言語でグラフを記述してpdfやpngとかで出力できる。
GraphViz for discrete math studentsというページでdotのサンプルを確認した。
僕の場合、重み付き有向グラフの描画をできれば良いのでこれだけでよかった。
<雑なdotサンプル>
digraph {
a -> b[label="0.1",weight="0.1"];
b -> c[label="0.2",weight="0.2"];
c -> a[label="0.3",weight="0.3"];
}
weightは、重みをいれたらいいのは分かるが、ラベルとして表示されるわけではなかった。
グラフ描画をいいかんじにしてくれるというくらいの認識。
↓manはこう言ってました。
weight=n where n is the integer cost of the edge.
Values greater than 1 tend to shorten the edge.
Weight 0 flat edges are ignored for ordering nodes.
おしまい。
雑に型推論するものを書いたぞ。
方程式を導出してそれを解くということをしただけ。
サポートする構文、組み込み関数
構文
ifとfunとlambda(1つ以上の引数関数の糖衣構文として)
(if bool a a) (fun x body) (lambda (x1 x2 ... ) body)
組み込み関数
succ + zero? の3つだけ。
例
関数適用 (zero? (+ 1 2)) ;boolean 整数をいれて、2加えて返す関数 (fun a (succ (succ a))) ;integer -> integer 多相型 (fun a a) ;T4 -> T4 ifの型推論 (lambda (a b)(if a 1 b)) ;boolean -> integer -> integer 合成関数 (lambda (a b)(fun x (a (b x)))) ;(T10 -> T11) -> (T9 -> T10) -> T9 -> T11
雑なソースコード
;----------------------------------------------------- ; ; data ; ;----------------------------------------------------- (define builtin-functions '((succ . (function . (integer . integer))) (+ . (function . (integer . (function . (integer . integer))))) (zero? . (function . (integer . boolean))))) ;----------------------------------------------------- ; ; curry ; ;----------------------------------------------------- (define (lmd-to-curry-fun code) (let ((param (cadr code)) (body (caddr code))) (let loop ((p param)) (if (null? p) body `(fun ,(car p) ,(loop (cdr p))))))) (define (curry-apply code) (let loop ((args (reverse (cdr code)))) (if (null? (cdr args)) `(,(car code) ,(car args)) `(,(loop (cdr args)) ,(car args))))) (define (test-convert code) (if (pair? code) (case (car code) ((lambda) (let ((body (test-convert (caddr code)))) (lmd-to-curry-fun `(lambda ,(cadr code) ,body)))) ((fun) (let ((body (test-convert (caddr code)))) `(fun ,(cadr code) ,body))) ((if) (let ((test (test-convert (cadr code))) (true (test-convert (caddr code))) (false (test-convert (cadddr code)))) `(if ,test ,true ,false))) (else (let ((args (map test-convert (cdr code))) (f (test-convert (car code)))) (curry-apply (cons f args))))) code)) ;----------------------------------------------------- ; ; type inference ; ;----------------------------------------------------- (define extract #f) (let ((type-vars 0)) (define (publish-type-vars) (set! type-vars (+ type-vars 1)) (cons 'type-var type-vars)) (define (catch-type env sym) (cond ((assv sym env) => cdr) (else (display "ERROR::unbound variable ")(display sym)(display " env=")(display env)(newline)))) (set! extract (lambda (env code) (cond ((integer? code) '(() . integer)) ((boolean? code) '(() . boolean)) ((symbol? code) (cons '() (catch-type env code))) ((eqv? (car code) 'if) (let* ((et1 (extract env (cadr code))) (et2 (extract env (caddr code))) (et3 (extract env (cadddr code)))) (let ((e4 (append (car et1) (car et2) (car et3) (list (cons (cdr et1) 'boolean) (cons (cdr et2) (cdr et3)))))) (cons e4 (cdr et2))))) ((eqv? (car code) 'fun) (let ((t (publish-type-vars))) (let ((et0 (extract (cons (cons (cadr code) t) env) (caddr code)))) (cons (car et0) (cons 'function (cons t (cdr et0))))))) (else (let* ((et1 (extract env (car code))) (et2 (extract env (cadr code)))) (let ((t (publish-type-vars))) (let ((e3 (append (car et1) (car et2) (list (cons (cdr et1) (cons 'function (cons (cdr et2) t))))))) (cons e3 t))))) )))) (define (expand obj env) (cond ((type-var? obj) => (lambda (id) (let loop ((p env)) (cond ((null? p) obj) ((eqv? id (caar p))(cdar p)) (else (loop (cdr p))))))) (else obj))) (define (expand-rec obj env) (cond ((symbol? obj) obj) ((type-var? obj) (let ((expanded-obj (expand obj env))) (if (and (type-var? expanded-obj) (eqv? (type-var? expanded-obj)(type-var? obj))) expanded-obj (expand-rec expanded-obj env)))) ((eqv? (car obj) 'function) `(function . (,(expand-rec (cadr obj) env) . ,(expand-rec (cddr obj) env)))) (else obj))) (define (unify e equations) (cond ((null? equations) e) ((null? (car equations)) (unify e (cdr equations))) (else (let ((left (expand (caar equations) e)) (right (expand (cdar equations) e))) (cond ((equal? left right) (unify e (cdr equations))) ((and (not (type-var? right)) (type-var? left) ) => (lambda (id) (unify (cons (cons id right) e) (cdr equations)))) ((and (not (type-var? left)) (type-var? right)) => (lambda (id) (unify (cons (cons id left) e) (cdr equations)))) ((and (pair? left)(pair? right) (eqv? (car left) 'function) (eqv? (car right) 'function)) (unify e `(,(cons (cadr left)(cadr right)) ,(cons (cddr left)(cddr right)) . ,(cdr equations)))) (else (display "TYPE ERROR")(newline))))))) (define (type-var? o) (and (pair? o)(eqv? (car o) 'type-var)(cdr o))) (define (type->string obj) (cond ((symbol? obj) (symbol->string obj)) ((eqv? (car obj) 'type-var) (string-append "T" (number->string (cdr obj)))) ((eqv? (car obj) 'function) (let ((arg (if (and (pair? (cadr obj)) (not (type-var? (cadr obj)))) (string-append "(" (type->string (cadr obj)) ")") (type->string (cadr obj)))) (body (type->string (cddr obj)))) (string-append arg " -> " body ))))) ;----------------------------------------------------- ; ; REPL ; ;----------------------------------------------------- (define (eqshow eqs) (let loop ((l eqs)) (cond ((null? l) '()) ((null? (car l)) (loop (cdr l))) (else (display "::::: ")(display (caar l))(display " = ")(display (cdar l))(newline)(loop (cdr l)))))) (let type-check-loop () (let* ((input (test-convert (read))) (analyzed-input (extract builtin-functions input)) (kai (unify '() (car analyzed-input))) (ret (expand-rec (cdr analyzed-input) kai))) (display (type->string ret))(newline) (type-check-loop)))
gentooの/etc/portage/distfilesをきれいにするぞ
ecleanを使う。
標準では入っていないので、gentoolkitを入れる必要がある。
dオプションをつけると、現在のバージョン以外が消える。(man曰く、only keep the minimum for a reinstallation)
日付やサイズ等のオプションもつけられるが、再ダウンロードすればよいので気にせず消した。
eclean distfiles -d
scheme処理系を実装中です。
Kobe University Advent Calendar 2016の22日目の記事です。
そして私はB3のniyarinです。
本編に関係ないネタ
本編が少し雑なので、xmas treeを出力するスクリプトをてきとーにschemeで書きました
(define decorate #f) (let ((pos-seed 1) (shape-seed 1)) (set! decorate (lambda (leaves) (for-each (lambda (_) (set! pos-seed (modulo (+ (* pos-seed 3) 7) 26)) (set! shape-seed (modulo (+ shape-seed 1) 3)) (if (< pos-seed (string-length leaves)) (string-set! leaves pos-seed (list-ref '(#\@ #\? #\$) shape-seed)))) (make-list 3)) leaves))) (define tree-data (let loop1 ((width '( 0 2 6 10 ))(updates '(1 1 2 2 ) )) (if (null? width) '() (append (let loop2 ((w (min 1 (car width)))) (if (> w (car width)) '() (cons (string-append (substring " " 0 (- 13 w)) (decorate (substring "*********************" 0 (+ (* w 2) 1)))) (loop2 (+ w (car updates) ))))) (loop1 (cdr width)(cdr updates)))))) (define tree-pot (let ((space " ") (edge "| |") (bottom "-------")) (append (map (lambda (_) (string-append space edge)) (make-list 2 )) (list (string-append space bottom))))) (for-each (lambda (x) (display x)(newline)) (append tree-data tree-pot))
結果
*
*?*
*****
*?*
*******
*?*********
***
*?*****
**********$
*?*************
**********$@**?****
| |
| |
-------
ネタおしまい。
scheme処理系を実装している話
・未完成です。
・上のxmas tree scriptも動きません
・ページ
今回は、中でどんな処理をしているのか雑に説明します。
処理系の概要
・r7rsを目指す。
・JavaScriptで実装。
・VM型
終わったこと
・末尾呼び出し最適化
・末尾呼び出しでなくても最適化する
・syntax-rules
・第一級継続
・dynamic-wind
・多値
コンパイル手順
α変換&マクロ展開&syntax展開 → cps conversion → closure conversion & lambda lifting
→VMコード生成
α変換
名前の衝突は後の処理で厄介になりそうなのでリネームします。
例
(lambda (a)(lambda (a) (+ a 1))) -> (lambda (a) (lambda (a_2) (+ a_2 1)))
cps conversion
継続を陽に表すようなコードに変換します。
私の処理系では、これを第一級継続、末尾呼び出し最適化に使用しているので割と大事な処理だったりします。
例
(+ (+ a b)(+ c d))
->
(+ a b (lambda (r1)
(+ c d (lambda (r2) (+ r1 r2 ret)))))
closure conversionとlambda lifting
自由変数を削除する変換です
lambda liftingはlambda式のparameterを拡張する変換です
例
(let ((a 1)) ((lambda (b c) (+ a b c )) 2 3)) -> (let ((a 1)) ((lambda (b c a)(+ a b c )) 2 3 a ))
closure conversionは、closureを手続きと自由変数の値のペアで表現するという変換です。
末尾呼び出し最適化
すべての手続き呼び出しで、call stackを必要としないコードに変換することで実現しました。
具体的には、cps conversionで戻りアドレスを不要にして、
closure conversionで外の自由変数を削除するという方針です。
おしまい
syntax-rulesの仕様を読んで確認した
r7rsのsyntax-rulesのパターンの部分の仕様を読んで確認する。(vectorは省く)
とる形は、以下の4つ(Pはパターンで、[ellipsis]は、0個以上の繰り返し)
1. (P1 ... Pn )
2. (P1 ... Pn . Pn+1)
3. (P1 ... Pk Pe [ellipsis] Pm+1 ... Pn)
4. (P1 ... Pk Pe [ellipsis] Pm+1 ... pn . Px )
つまり、
1.真性リストで[ellipsis]を含まない。
2.非真性リストで[ellipsis]を含まない。
3.真性リストで[ellipsis]を含む。
4.非真性リストで[ellipsis]を含む。
ということか。
1
(define-syntax check-1 (syntax-rules () ((_ (a b c d e)) (quote (a b c d e))))) (display (check-1 (1 2 3 4 5)))(newline) ;(1 2 3 4 5)
真性リストで同じ要素数のものだけしかマッチしない。
特になし
2
(define-syntax check-2 (syntax-rules () ((_ (a b . c))(quote (a b c))))) (display (check-2 (1 2 )))(newline);(1 2 ()) (display (check-2 (1 2 3 )))(newline);(1 2 (3)) (display (check-2 (1 2 3 4 5)))(newline);(1 2 (3 4 5)) (display (check-2 (1 2 . 3)))(newline);(1 2 3)
非真性、真性どちらでもよく、左から順にマッチさせていき、のこりを最後のcdr部にマッチさせる。
これも、特になし。
3
(define-syntax check-3 (syntax-rules () ((_ (a b ... c d ))(quote (a b ... c d ))))) (display (check-3 (1 2 3 4 5)))(newline);(1 2 3 4 5) (display (check-3 (1 2 3)))(newline);(1 2 3)
真性リストで、[ellipsis]の左側と右側をマッチさせて、残りを[ellipsis]の所にマッチさせる。
これも、特になし。
4-1
全部、パターン変数の場合。
(define-syntax check-4a (syntax-rules () ((_ (a b ... c . d))(quote (b ... d ))))) (display (check-4a (1 2 3 4 5)))(newline);(2 3 4 ()) (display (check-4a (1 2 3 4 . 5)))(newline);(2 3 5) (display (check-4a (1 2 3)))(newline);(2 ())
処理系によっては、動かなかったり、明らかに間違った結果がでたりした。
saggitarius0.6.11やgauche0.9.5の結果だと、
非真性リストを入れると、末尾cdr同士、それ以外同士でマッチングし、
真性リストを入れると、patternの末尾cdrにnullがマッチして、全部その左側にマッチする。
4-2
定数を入れた場合。
(define-syntax check-4b (syntax-rules () ((_ (1 2 ... 3 . d))(quote d )))) (print (check-4b (1 2 2 2 3 . 4 )));4
真性リストを入力した場合、最後のcdr要素(null)だけが、Pxにマッチするので、
Pnまでうまくマッチできそうなケースでもだめだね。
