nobsunで出たアイディア
Gaucheの起動オプションで、評価方式を普通のEagerではなくLazyに 切り替えられたりするとうれしいなぁ（これじゃ、ぜんぜんSchemeじゃないか。^^;)
を発展させてってみよう、のコーナー。
(let* ((a (read-char))
(b (read-char))
(c (read-char)))
...)
(let ((a (read-char)))
(let ((b (read-char)))
(let ((c (read-char)))
...)))
do p <- e1; e2 === e1 >>= ? p -> e2
=== ((lambda (p) e2) (selector e1)) (厳密には違うけど)
=== (let ((p (selector e1))) e2) (厳密には違うけど)
(letrec ((bot (lambda () (bot))))
((lambda (x) 4) (bot)))
(let*-values ((a state1) (read-char-functional state0))
(b state2) (read-char-functional state1))
(c state3) (read-char-functional state2)))
...)
横槍の横槍ですみません。macroの話題がでてきたところで便乗して...ひとつ、質問させて下さい。 普段は、lua使いなので、schemeについてはいまひとつ？なのですが、正規表現を使える macro の処理系というのは存在しないのでしょうか？ あそこまで強力にするのであれば、lexer並の機能を期待してしまうのは自然なことだと思うのですが。ちなみにgemaのような仕様 をscheme風に整理したものを想像しています。 あっ”Scheme:マクロの効用”の方に書くべきだったか。--toki?
teranishi: 動くものが無いと理解できない人間なので、とりあえず作ってみました。
#!/bin/sh
:; exec gosh -fno-inline -- $0 "$@"
(define-module lazy
(use srfi-1)
(use util.match)
(export lazy-convert replace-primitive! force-all)
(define *lazy-table* (make-hash-table))
(define (lazy-convert expr)
(let ((expr (macroexpand expr)))
(cond ((or (symbol? expr) (identifier? expr)) (list force expr))
((literal? expr) expr)
((hash-table-get *lazy-table* (unwrap-identifier (car expr)) #f) => (cut <> expr))
(else `(,(lazy-convert (car expr)) ,@(map delay-convert (cdr expr)))))))
(define (delay-convert expr)
(let ((expr (macroexpand expr)))
(cond ((literal? expr) expr)
((eq? (unwrap-identifier (car expr)) 'lambda)
((hash-table-get *lazy-table* 'lambda) expr))
(else `(delay ,(lazy-convert expr))))))
(define (divide-rest-arg lst)
(do ((rest lst (cdr rest)) (prev () (cons (car rest) prev)))
((not (pair? rest))
(values (reverse! prev) rest))))
(define-macro (replace-primitive! spec . ret)
(receive (prev rest) (divide-rest-arg (cdr spec))
(let ((original (gensym))
(vars (map (lambda _ (gensym)) prev))
(ret (if (null? ret) values (car ret))))
`(set! ,(car spec)
(let ((,original ,(car spec)))
,(if (null? rest)
`(lambda ,vars
(,ret (,original ,@(map list prev vars))))
(let ((rest-var (gensym)))
`(lambda ,(append! vars rest-var)
(,ret (,apply ,original ,@(map list prev vars)
(,map ,rest ,rest-var)))))))))))
(define (force-all expr)
(let ((forced ()))
(let loop ((expr expr))
(cond ((promise? expr) (loop (force expr)))
((and (pair? expr)
(not (memq expr forced)))
(push! forced expr)
(set-car! expr (loop (car expr)))
(set-cdr! expr (loop (cdr expr)))
expr)
(else expr)))))
(define (literal? expr)
(or (not-pair? expr)
(eq? (unwrap-identifier (car expr)) 'quote)))
(define (unwrap-identifier expr)
(if (identifier? expr)
(unwrap-syntax expr)
expr))
(hash-table-put! *lazy-table* 'lambda
(lambda (expr)
`(,(car expr) ,(cadr expr) ,@(map lazy-convert (cddr expr)))))
(hash-table-put! *lazy-table* 'if
(lambda (expr)
`(,(car expr) ,@(map lazy-convert (cdr expr)))))
(hash-table-put! *lazy-table* 'and (hash-table-get *lazy-table* 'if))
(hash-table-put! *lazy-table* 'or (hash-table-get *lazy-table* 'if))
(hash-table-put! *lazy-table* 'define
(match-lambda
((name (fun . args) body ...)
`(,name (,fun . ,args) ,@(map lazy-convert body)))
((name var val)
`(,name ,var ,(delay-convert val)))))
(hash-table-put! *lazy-table* 'begin (hash-table-get *lazy-table* 'if))
(hash-table-put! *lazy-table* 'let
(lambda (expr)
`(,(car expr) ,(map (lambda (expr) `(,(car expr) ,(delay-convert (cadr expr)))) (cadr expr))
,@(map lazy-convert (cddr expr)))))
(hash-table-put! *lazy-table* 'define-macro values)
)
(import lazy)
(replace-primitive! (null? force))
(replace-primitive! (car force) force)
(replace-primitive! (cdr force) force)
(replace-primitive! (zero? force))
(replace-primitive! (+ . force))
(replace-primitive! (- . force))
(replace-primitive! (write/ss force-all . force))
(define load
(lambda (file)
(call-with-input-file file
(lambda (port)
(read-eval-print-loop
(lambda () (read port))
(lambda (expr env) (eval (lazy-convert expr) env))
(lambda _ #f)
(lambda _ #f))))))
(define (main args)
(read-eval-print-loop
read
(lambda (expr env) (eval (lazy-convert expr) env))
(lambda args (for-each (lambda (expr)
(write/ss expr)
(newline))
args))))
実行例
gosh> (define (zip-with fun lis1 lis2)
(if (or (null? lis1) (null? lis2))
'()
(cons (fun (car lis1) (car lis2))
(zip-with fun (cdr lis1) (cdr lis2)))))
zip-with
gosh> (define (take lis k)
(if (zero? k)
'()
(cons (car lis)
(take (cdr lis) (- k 1)))))
take
gosh> (define ones (cons 1 ones))
ones
gosh> (take ones 10)
(1 1 1 1 1 1 1 1 1 1)
gosh> (define nums (cons 1 (zip-with + ones nums)))
nums
gosh> (take nums 10)
(1 2 3 4 5 6 7 8 9 10)
gosh> (define fibs (list* 1 1 (zip-with + fibs (cdr fibs))))
fibs
gosh> (take fibs 10)
(1 1 2 3 5 8 13 21 34 55)
ただ、srfi-1の関数の定義を入力しても、まともに動かない場合が多々ありました。 たとえば、以下の関数は無限ループに陥ります。 (このような再帰は、append-mapやany,everyで使われています)
gosh> (define (error-fun elt rest)
(if (null? rest)
elt
(cons elt (error-fun (car rest) (cdr rest)))))
error-fun
gosh> (define ones (cons 1 (error-fun (car ones) (cdr ones))))
ones
gosh> (take ones 10)
Expressing the above algorithm in terms of {delay, force} in fact does not correctly capture common notions of call-by-need evaluation semantics.
teranishi(2005/03/26 02:35:26 PST):上で言っていた入出力の話を少し。
(let* ((a (read-char))
(b (read-char))
(c (read-char)))
...)
で文字の順番を保証する方法ですが、begin が使えるなら
(let* ((a (read-char))
(b (begin a (read-char)))
(c (begin b (read-char))))
...)
と書き換えれば、特別な事をしなくても保証できると考えました。
しかし、この let* 文の中だけの実行順を保証できても、 let* 文自体がいつ実行されるかが確定しなければ、 実行開始から数えて何番目の文字が読まれるかは分からなくなってしまいます。 つまり、この let* を含む関数も実行順を保証しなければならないという事です。 さらに let* を含む関数を呼び出す関数も実行順を保証しなければならず・・・ と考えていくと、結局実行開始から let* に至る全ての関数で 実行順を保証する必要がある事になります。
すべての実行順を手動で保証していくのは大変なので、 以前いじっていたモナドを使う事を考えました。
(define (return val)
(lambda (prev)
(begin prev val)))
(define (>>= m f)
(lambda (prev)
(let ((new-prev (m prev)))
((f new-prev) new-prev))))
要するに、次の処理を実行する前にやっておかなければならない処理 (prev) を 持ち回って(>>=の処理)、順番を保証したい処理をする前に prev を実行することを 保証するのです(returnの処理)。 ついでに、read-char のように実行順を必ず保証したい関数は、 この枠組みでしか呼び出せないようにしてしまいます。
(define (read-charM)
(lambda (prev)
(begin prev (read-char))))
あとは、Monadic Programming in Schemeの LetM* や beginM を使えば、 実行順の保証が楽にできると考えたのです。
(letM* ((a (read-charM))
(b (read-charM))
(c (read-charM)))
...)
しかし、この枠組みで書いたコードは、「let* の束縛を eager に評価する」 というルールを追加しただけの場合と見た目がほとんど変わらないので わざわざこんなことをする必要は無かったかも・・・
teranishi(2005/03/29 19:55:08 PST):とりあえず実装。
(define (return val)
(lambda (prev)
(begin prev val)))
(define (>>= m f)
(lambda (prev)
(let ((new-prev (m prev)))
((f new-prev) new-prev))))
(define (read-charM)
(return (read-char)))
(define (write/ssM val)
(return (write/ss val)))
(define-macro (>> m1 m2)
`(>>= ,m1 (lambda (,(gensym)) ,m2)))
(define fail error)
(define-macro (letM binding expr)
`(>>= ,(cadar binding) (lambda (,(caar binding)) ,expr)))
(define-macro (letM* bindings expr)
(if (null? (cdr bindings))
`(letM (,(car bindings)) ,expr)
`(letM (,(car bindings))
(letM* ,(cdr bindings) ,expr))))
(define-macro (beginM . body)
(if (null? (cdr body))
(car body)
`(>> ,(car body) (beginM ,@(cdr body)))))
実行例
gosh> ((letM* ((a (read-charM)) (b (read-charM))) (beginM (write/ssM b) (write/ssM a))) #f)xy #\y#\x0