Schemeによるquasiquoteのtoy実装

強いストレスが溜まっているのでせめてもの発散に書いてみた．地球が消えてしまえばいいのに．

><

add

普通のSchemeで言う +

qt

quoteすなわち '

qqt

quasiquoteすなわち `

uqt

unquoteすなわち ,

バグってないとよいのだけど... 例はR5RSから採った．

(define (ebal-add ae) ; ae == (+ e1 e2 ... eN)
  (if (pair? ae)
      (let loop ((es (cdr ae)) (acc 0))
        (if (null? es)
            acc
            (loop (cdr es) (+ (ebal (car es)) acc))))
      ae))

(define (ebal-quote qe) ; qe == (qt e)
  (cadr qe))

(define (ebal-quasiquote qqe) ; qqe == (qqt e)
  (let rec ((e (cadr qqe)) (depth 0))
    ;(write '<) (write e) (write '>) (newline)
    (if (pair? e) ; e == a| (uqt e1) | (qqt e1) | (e1 e2 ... eN)
        (case (car e)
          ((uqt) (if (= depth 0)
                     (ebal (cadr e))
                     (cons 'uqt (rec (cdr e) (- depth 1)))))
          ((qqt) (cons 'qqt (rec (cdr e) (+ depth 1))))
          (else (map (lambda (x) (rec x depth)) e)))
        e)))

(define (ebal e)
  (if (pair? e)
      (case (car e)
        ((add) (ebal-add e))
        ((qt) (ebal-quote e))
        ((qqt) (ebal-quasiquote e))
        (else (write 'p) (write e) (write 'q))) ; error!
      e))

;;; 以下は動作試験

;; 10 => 10
(define e000 '10 )
(write (ebal e000)) (newline) (newline)

;; (+ 1 2 3) => 6
(define e010 '(add 1 2 3) )
(write (ebal e010)) (newline) (newline)

;; (+ 1 2 (+ 1 2)) => 6
(define e020 '(add 1 2 (add 1 2)) )
(write (ebal e020)) (newline) (newline)

;; '1 => 1
(define e030 '(qt 1) )
(write (ebal e030)) (newline) (newline)

;; 'abc => abc
(define e035 '(qt abc) )
(write (ebal e035)) (newline) (newline)

;; '(+ 1 2 (+ 1 2)) => (+ 1 2 (+ 1 2))
(define e040 '(qt (add 1 2 (add 1 2))) )
(write (ebal e040)) (newline) (newline)

;; `10 => 10
(define e050 '(qqt 10) )
(write (ebal e050)) (newline) (newline)

;; `(+ (+ 1 2) (+ 3 4)) => (+ (+ 1 2) (+ 3 4))
(define e060 '(qqt (add (add 1 2) (add 3 4))) )
(write (ebal e060)) (newline) (newline)

;; `,123 => 123
(define e065 '(qqt (uqt 123)) )
(write (ebal e065)) (newline) (newline)

;; `,(+ 1 2) => 3
(define e067 '(qqt (uqt (add 1 2))) )
(write (ebal e067)) (newline) (newline)

;; `(+ ,(+ 1 2) (+ 3 4)) => (+ 3 (+ 3 4))
(define e070 '(qqt (add (uqt (add 1 2)) (add 3 4))) )
(write (ebal e070)) (newline) (newline)

;; `(+ ,(+ 1 2) ',(+ 3 4)) => (+ 3 '7)
(define e080 '(qqt (add (uqt (add 1 2)) (qt (uqt (add 3 4))))) )
(write (ebal e080)) (newline) (newline)

;; `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) => (a `(b ,(+ 1 2) ,(foo 4 d) e) f)
(define e090 '(qqt (a (qqt (b (uqt (add 1 2))
                              (uqt (foo (uqt (add 1 3))
                                        d))
                              e))
                      f)) )
(write (ebal e090)) (newline) (newline)


;; `(a `(b ,,'x ,','y d) e) => (a `(b ,x ,'y d) e)
(define e100 '(qqt (a (qqt (b (uqt (uqt (qt x)))
                              (uqt (qt (uqt (qt y))))
                              d))
                      e)))
(write (ebal e100)) (newline) (newline)

;; `(list ,(+ 1 2) 4) => (list 3 4)
(define e110 '(qqt (list (uqt (add 1 2)) 4)) )
(write (ebal e110)) (newline) (newline)