December 31th Thurday 2009

The implemention of Y combiner is here.

 

(define Y
  (lambda (F)
    (let ((W (lambda (x)
               (F (lambda arg (apply (x x) arg))))))
      (W W))))

or

(define Y
  (lambda (x)
    ((lambda (maker)
       (x (lambda (arg) ((maker maker) arg))))
     (lambda (maker)
       (x (lambda (arg) ((maker maker) arg)))))))

 

To test them, use the following functions.

 

(define F*
  (lambda (func-arg)
    (lambda (n)
      (if (= n 0) 1
          (* n (func-arg (- n 1)))))))

(define M*
  (lambda (f)
    (lambda (ls)
      (if (null? (cdr ls)) (car ls)
          (max (car ls) (f (cdr ls)))))))

 

with-syntax

 

(define-syntax p.car
  (identifier-syntax
    (_ (car p))
    ((set! _ e) (set-car! p e))))

(define p (cons 4 5))

(set! p.car 15)
p.car => 15
p => (15 5)

(define-syntax with-syntax
  (lambda (x)
    (syntax-case x ()
      ((_ ((p e0) ...) e1 e2 ...)
       (syntax (syntax-case (list e0 ...) ()
                 ((p ...) (begin e1 e2 ...))))))))

(define-syntax loop
  (lambda (x)
    (syntax-case x ()
      ((k e ...)
       (with-syntax ((break (datum->syntax-object (syntax k) 'break)))
         (syntax (call/cc
                  (lambda (break)
                    (let f () e ... (f))))))))))

Syntax Case Examples
例子
syntax-object->datum 的用途
这个函数可以把一个 syntax 对象变成一个 datum, 就像一个 quote 返回的东西那样。我们可以用它来判断两个变量所对应的 symbol 是否相同。

用下面这个例子可以体验一下 syntax-case:

(define-syntax print-verbatim
  (lambda (x)
    (display x)
    (newline)
    (display (syntax-object->datum x))
    (syntax (newline))))

(print-verbatim "haha")

结果是：

#<syntax:STDIN::6508>
(print-verbatim haha)

第一个 display 显示了 x 是一个 syntax 对象。第二个 display 显示了把 x 转化成一个 datum 之后的结果。其实就是

'(print-verbatim haha)

用法举例：
一般说来 (eq? foo bar) 只能判断两个变量指向的对象是否相等，而不能判断两个变量的名字是否相同。下面这个 syntax-case 定义的宏就可以判断这个属性：

(define-syntax symbolic-identifier=?
  (lambda (x)
    (let ((syn (syntax-object->datum x)))
      (if (eq? (cadr syn) (caddr syn))
          (syntax #t)
          (syntax #f)))))

datum->syntax-object 的用途
datum->syntax-object 的语法是：

(datum->syntax-object template-identifier obj)

它可以由一个对象 obj, 构造一个 syntax 对象，这个 syntax 对象跟 template-identifier 由同样的语法上下文。

这句话有点不好理解，其实它就是说：“就当 obj 是在 template-identifier 出现的时候出现的。”

再不好理解就看看这个例子：

(define-syntax loop
  (lambda (x)
    (syntax-case x ()
      ((k e ...)
       (with-syntax ((break (datum->syntax-object (syntax k) 'break)))
          (syntax (call-with-current-continuation
                    (lambda (break)
                      (let f () e ... (f))))))))))

(let ((n 3) (ls '()))
  (loop
    (if (= n 0) (break ls))
    (set! ls (cons 'a ls))
    (set! n (- n 1))))  (a a a)

这是正确的。

如果我们用通常的办法定义 break, 我们的输入

(loop
    (if (= n 0) (break ls))
    (set! ls (cons 'a ls))
    (set! n (- n 1)))

里面调用 break 时会出错。因为 "break" 这个名字，在 loop 被 定义 时的含义(A)，和 loop 被 调用 时的含义(B)，是不同的。

所以，我们在 syntax-case 中，把 "break" 这个名字，绑定到由 datum->syntax-object 构造的一个 syntax 对象。这个 syntax 对象其实就是 break 这个名字，只不过它的上下文是跟 (syntax k), 也就是 "loop" 被 调用 的时候一样。

这样，

(call-with-current-continuation
  (lambda (break)
    (let f () e ... (f))))

里面的 "break" 实际上就是指 loop 被调用的时候那个环境里的 break，而不是 loop 被定义的时候的环境里的 break.

这样，在 loop 被调用的时候，break 绑定到了跟当前的 loop 同样的上下文。所以 loop 的输入里面能够调用到 break.

下面这个例子里。我们定义一个 include, 它跟 load 类似，不过它读入的文件里的名字就像是在当前调用时被插入的一样。

(define-syntax include
  (lambda (x)
    (define read-file
      (lambda (fn k)
        (let ((p (open-input-file fn)))
          (let f ((x (read p)))
            (if (eof-object? x)
                (begin (close-input-port p) '())
                (cons (datum->syntax-object k x)
                      (f (read p))))))))
    (syntax-case x ()
       ((k filename)
        (let ((fn (syntax-object->datum (syntax filename))))
          (with-syntax (((exp ...) (read-file fn (syntax k))))
            (syntax (begin exp ...))))))))

(let ((x "okay"))
  (include "f-def.scm")
  (f))

如果你有一个文件叫做 f-def.scm 里面有一些内容，比如：

(define f (lambda () x))
(for-each display `("I see! x is: " ,x "/n"))

那么结果会是：

I see! x is: okay
"okay"

这是怎么回事呢？因为经过 datum->syntax-object 的处理，这条 define 语句

(define f (lambda () x))

就像在 include 被调用时出现的一样，也就是说，它能看到 include 被调用时能看到的一切上下文。所以，这个 define 能够看到 let 环境内的局部变量 ok，它的值是 "okay".

有关 datum->syntax-object 的另一个例子请看 SyntaxDefinitions 里的那个 syntax-case 的例子.

with-syntax 的定义
with-syntax 可以用 syntax-case 来定义：

(define-syntax with-syntax
  (lambda (x)
    (syntax-case x ()
      ((_ ((p e0) ...) e1 e2 ...)
       (syntax (syntax-case (list e0 ...) ()
                 ((p ...) (begin e1 e2 ...))))))))

有点不好理解，实际上 syntax-case：

(syntax-case exp (literal ...) clause ...)

其中每个 clause 可以是：

(pattern output-expression)
(pattern fender output-expression)

所以 syntax-case 是用 exp 的值，去匹配 pattern.

这样 with-syntax 内部的

(syntax-case (list e0 ...) ()
  ((p ...) (begin e1 e2 ...)))

就容易理解了。这里我们在用从原来的输入中提取出来的 (list e0 ...) 去匹配 (p ...). 如果我们的输入是：

(with-syntax ((break (datum->syntax-object (syntax k) 'break)))
   ...
   ...)

p 就是 break, e0 就是 (datum->syntax-object (syntax k) 'break).

所以它就被转化成：

......
(syntax-case (list (datum->syntax-object (syntax k) 'break) ...) ()
  ((break ...) (begin e1 e2 ...)))

我们是在用 (datum->syntax-object (syntax k) 'break) 去匹配 break. 那么 break 就得到了 (datum->syntax-object (syntax k) 'break) 的“值”。

那么这个名字 break 就变成了跟 loop 被调用时具有同样语法上下文的一个名字 --- break. 你可以从 loop 的环境里调用它。

 

;;; dynamic wind
(define (dynamic-wind before thunk after)
    (before)
    (call-with-values
        (lambda ()
            (thunk))
        (lambda vals
            (after)
            (apply values vals))))

;;; values
(define (values . sth)
    (call/cc (lambda (cc)
        (apply cc sth))))
 

;;; chnum-num

 

(define (f x) (cons 'x x))

(define (zero f)
  (lambda (x)
    x))

(define (one f)
  (lambda (x)
    (f x)))

(define (two f)
  (lambda (x)
    (f (f x))))

(define (three f)
  (lambda (x)
    (f (f (f x)))))

(define (add-one n)
  (lambda (f)
    (lambda (x)
      (f ((n f) x)))))

(define (add a b)
  (lambda (f)
    (lambda (x)
      ((a f) ((b f) x)))))

(define (mul a b)
  (lambda (f) (lambda (x) ((a (b f)) x))))

 

 

 (define (force delayed-object)
  (delayed-object))

(define (memo-proc proc)
  (let ((already-run? false) (result false))
    (lambda ()
      (if (not already-run?)
          (begin (set! result (proc))
                 (set! already-run? true)
                 result)
          result))))
;;(memo-proc (lambda () <exp>))
;;(delay <exp>)
;;is syntactic sugar for
;;(lambda () <exp>)

(define-syntax cons-stream
  (lambda (x)
    (syntax-case x ()
      ((_ a b) (syntax (cons a (delay b)))))))

(define-syntax car-stream
  (lambda (x)
    (syntax-case x ()
      ((_ s) (syntax (car s))))))

(define-syntax cdr-stream
  (lambda (x)
    (syntax-case x ()
      ((_ s) (syntax (force (cdr s)))))))

(define (for-each-stream pred s)
  (pred (car-stream s))
  (for-each-stream pred (cdr-stream s)))

(define (show-money to s)
  (call/cc (lambda (end)
             (for-each-stream (lambda (m)
                                (if (> m to)
                                    (end m))
                                (display m)
                                (newline))
                              s))))

(define (money-tree n)
  (cons-stream n (money-tree (* n n))))

(define salary (money-tree 2))

(define (sieve stream)
  (cons-stream
   (stream-car stream)
   (sieve (stream-filter
           (lambda (x)
             (not (divisible? x (stream-car stream))))
           (stream-cdr stream)))))

(define primes (sieve (integers-starting-from 2)))

Now to find a particular prime we need only ask for it:

(stream-ref primes 50)
233