Scheme手習い 10章 インタープリタ

Scheme手習い10章のインタープリタを書いてみた。

(define value
    (lambda (e)
        (meaning e '())))

(define meaning
    (lambda (e table)
        ((expression-to-action e) e table)))

(define expression-to-action
    (lambda (e)
        (cond
            [(atom? e) (atom-to-action e)]
            [else (list-to-action e)])))

(define atom?
    (lambda (a)
        (and (not (pair? a)) (not (null? a)))))

(define atom-to-action
    (lambda (e)
        (cond
            [(number? e) *self-evaluating]
            [else *identifier])))

(define list-to-action
    (lambda (e)
        (cond
            [(atom? (car e))
                (cond
                    [(eq? (car e) 'quote) *quote]
                    [(eq? (car e) 'lambda) *lambda]
                    [(eq? (car e) 'cond) *cond]
                    [else *application])]
            [else *application])))

(define *quote
    (lambda (e table)
        (second e)))

(define *self-evaluating
    (lambda (e table)
        e))

(define *identifier
    (lambda (e table)
        (lookup-in-table
            e
            table
            (lambda (name)
                (cond
                    [(eq? name '#t) #t]
                    [(eq? name '#f) #f]
                    [else (list 'primitive name)])))))

(define lookup-in-table
    (lambda (name table table-f)
        (cond
            [(null? table) (table-f name)]
            [else (lookup-in-entry
                      name
                      (car table)
                      (lambda (name)
                          (lookup-in-table
                              name
                              (cdr table)
                              table-f)))])))

(define lookup-in-entry
    (lambda (name entry entry-f)
        (lookup-in-entry-help
            name
            (first entry)
            (second entry)
            entry-f)))

(define first
    (lambda (l)
        (car l)))

(define second
    (lambda (l)
        (car (cdr l))))

(define lookup-in-entry-help
    (lambda (name names values entry-f)
       (cond
           [(null? names) (entry-f name)]
           [(eq? (car names) name) (car values)]
           [else (lookup-in-entry-help
                     name
                     (cdr names)
                     (cdr values)
                     entry-f)])))

(define *lambda
    (lambda (e table)
        (list 'non-primitive (cons table (cdr e)))))

(define *cond
    (lambda (e table)
        (evcon (cond-lines e) table)))

(define cond-lines
    (lambda (e)
        (cdr e)))

(define evcon
    (lambda (lines table)
        (cond
            [(meaning (question-of (car lines)) table)
             (meaning (answer-of (car lines)) table)]
            [else (evcon (cdr lines) table)])))

(define question-of
    (lambda (line)
        (first line)))

(define answer-of
    (lambda (line)
        (second line)))

(define *application
    (lambda (e table)
        (apply
            (meaning (function-of e) table)
            (evlis (arguments-of e) table))))

(define function-of
    (lambda (e)
        (car e)))

(define arguments-of
    (lambda (e)
        (cdr e)))

(define evlis
    (lambda (args table)
        (cond
            [(null? args) '()]
            [else (cons (meaning (car args) table) (evlis (cdr args) table))])))

(define apply
    (lambda (fun vals)
        (cond
            [(primitive? fun) (apply-primitive (second fun) vals)]
            [(non-primitive? fun) (apply-closure (second fun) vals)])))

(define primitive?
    (lambda (fun)
        (eq? (car fun) 'primitive)))

(define non-primitive?
    (lambda (fun)
        (eq? (car fun) 'non-primitive)))

(define apply-primitive
    (lambda (name vals)
        (cond
            [(eq? name 'car) (car (first vals))]
            [(eq? name 'cdr) (cdr (first vals))]
            [(eq? name 'cons) (cons (first vals) (second vals))]
            [(eq? name 'eq?) (eq? (first vals) (second vals))]
            [(eq? name 'atom?) (atom? (first vals))]
            [(eq? name 'not) (not (first vals))]
            [(eq? name 'null?) (null? (first vals))]
            [(eq? name 'number?) (number? (first vals))]
            [(eq? name 'zero?) (zero? (first vals))]
            [(eq? name 'add1) (+ (first vals) 1)]
            [(eq? name 'sub1) (- (first vals) 1)])))

(define apply-closure
    (lambda (closure vals)
        (meaning
            (body-of closure)
            (extend-table
                (new-entry (formals-of closure) vals)
                (table-of closure)))))

(define body-of
    (lambda (closure)
        (car (cdr (cdr closure)))))

(define table-of
    (lambda (closure)
        (car closure)))

(define formals-of
    (lambda (closure)
        (car (cdr closure))))

(define extend-table
    (lambda (entry table)
        (cons entry table)))

(define new-entry
    (lambda (names values)
        (list names values)))

以下のようにYコンビネータが実行できます!