File scheme/values.scm from the latest check-in

;; ===== 多値を作ってみる =====
;; Kent Dybvigのやつ https://www.scheme.com/tspl3/control.html#./control:s53
;; 多値に対して単一の値を返す事を単値と呼ぶとする。

;; 識別子magicを使う。多値なら(magic . args)というデータ。
;; (values . xs)
;;    １つの引数ならそのまま、そうでなければmagic化して返す。
;; (call/values producer consumer)
;;    producerが多値(magic)を返せばconsumerにapply、そうでなければ普通に(consumer arg)でcall。
;; (call/cc k)
;;    複雑。まず、既存のcall/ccに何らかの処理を挟みたい場合、次のように書く。
;;    (set! call/cc
;;          (let ([old-call/cc call/cc])
;;            (lambda (p)
;;              (old-call/cc
;;                (lambda (k)
;;                  (something) ここで何かやる
;;                  (p (lambda (x) (k x))))))))
;;      これで本来のcall/ccと同じように、例えば(lambda (k2) (k2 123))という手続きを渡すと、
;;    pに渡されている(lambda (x) (k x))がk2に入り、本来のkに123が適用される。
;;      ここで、(call/cc (lambda (k) (k 1 2 3)))という風に多値を渡せるようにしたい。
;;      つまり、pに渡される手続きが(lambda args kに多値を渡す)となれば良い。
;;    本来のkは単値
;;      ちなみに、こういう実験をするためにはcall/ccやcall-with-current-continuationは再定義可能な
;;    手続きじゃないといけない。

(define values #f)
(define call/values #f)

(let ([magic (cons 'multiple 'values)])
  (define (magic? x)
    (and (pair? x) (eq? (car x) magic)))

  (set! values
        (lambda args
          (if (null? (cdr args))
              (car args)
              (cons magic args))))

  (set! call/values
        (lambda (producer consumer)
          (let ([x (producer)])
            (if (magic? x)
                (apply consumer (cdr x))
                (consumer x)))))

  (let ([old-call/cc call/cc])
    (set! call/cc
          (lambda (p)
            (old-call/cc
             (lambda (k)
               (p (lambda args (k (apply values args))))))))
    (set! call-with-current-continuation call/cc)))

(define (print-all . xs)
  (for-each print xs))

;; 多値
(call/values (lambda () (values 1 2 3)) print-all)

;; 単値
(call/values (lambda () 'hello) print-all)

;; call/ccに多値を渡す
(call/values (lambda ()
               (call/cc (lambda (k) (k 'a 'b 'c))))
             print-all)

;; let-valuesを作る
(define-syntax let-vs
  (syntax-rules ()
    [(_ vars expr body ...)
     (call/values
      (lambda () expr)
      (lambda vars body ...))]))

(let-vs (a b c) (values 1 2 3)
        (print a)
        (print b)
        (print c))