[16.1.1] [tls 10] λ scheme 解释器

[ruandao]

(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)
    (cond
     ((null? entry) (entry-f name))
     (else (lookup-name name
            (keys entry)
            (vals entry)
            entry-f)))))
(define lookup-name
  (lambda(name names vals name-f)
    (cond
     ((null? names) (name-f name))
     ((eq? name (car names)) (car vals))
     (else (lookup-name name
            (cdr names)
            (cdr vals)
            name-f)))))
(define first car)
(define second
  (lambda(p)
    (car (cdr p))))
(define keys first)
(define vals second)

(define build
  (lambda(a b)
    (cons a
      (cons b '()))))
(define extend-table
  (lambda(entry table)
    (cons entry table)))
(define new-entry build)

(define atom?
  (lambda(x)
    (and (not (pair? x))
     (not (null? x)))))
(define expression-to-action
  (lambda(e)
    (cond
     ((atom? e) (atom-to-action e))
     (else (list-to-action e)))))

(define const-action
  (lambda(e actions)
    (cond
     ((null? actions) false)
     (else (or (eq? e (car actions))
           (const-action e (cdr actions)))))))
(define atom-to-action
  (lambda(e)
    (cond
     ((number? e) *const)
     ((const-action e
            '(#t #f cons car cdr
             null? eq? atom? zero?
             add1 sub1 number?))
      *const)
     (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 value
  (lambda(e)
    (meaning e '())))
(define meaning
  (lambda(e table)
    ((expression-to-action e) e table)))
(define *const
  (lambda(e table)
    (cond
     ((number? e) e)
     ((eq? e #t) #t)
     ((eq? e #f) #f)
     (else (build 'primitive e)))))
(define *quote
  (lambda(e table)
    (text-of e)))
(define text-of second)
(define *identifier
  (lambda(e table)
    (lookup-in-table e table initial-table)))
(define initial-table
  (lambda(name)
    (car '())))
(define *lambda
  (lambda(e table)
    (build 'non-primitive
       (cons table (cdr e)))))
(define table-of first)
(define formals-of second)
(define body-of third)

(define else?
  (lambda(x)
    (cond
     ((atom? x) (eq? x 'else))
     (else #f))))
(define answer-of second)
(define question-of first)
(define evcon
  (lambda(lines table)
    (cond
     ((else? (question-of (car lines)))
      (meaning (answer-of (car lines)) table))
     ((meaning (question-of (car lines)) table)
      (meaning (answer-of (car lines)) table))
     (else (evcon (cdr lines) table)))))

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

((lambda()
   (define e '(cond
           (coffee klatsch)
           (else party)))
   (define table '(
           ((coffee) (#t))
           ((klatsch party) (5 (6)))))
   (*cond e table)
   ))

(define evlis
  (lambda(args table)
    (cond
     ((null? args) '())
     (else (cons (meaning (car args) table)
         (evlis (cdr args) table))))))
(define *application
  (lambda(e table)
    (apply*
     (meaning (function-of e) table)
     (evlis (arguments-of e) table))))
(define function-of car)
(define arguments-of cdr)
(define primitive?
  (lambda(l)
    (eq? (first l) 'primitive)))
(define non-primitive?
  (lambda(l)
    (eq? (first l) 'non-primitive)))
(define apply*
  (lambda(fun vals)
    (cond
     ((primitive? fun) (apply-primitive (second fun) vals))
     ((non-primitive? fun)
      (apply-closure (second fun) vals)))))

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

(define :atom?
  (lambda(x)
    (cond
     ((atom? x) #t)
     ((null? x) #f)
     ((eq? (car x) 'primitive)
      #t)
     ((eq? (car x) 'non-primitive)
      #t)
     (else #f))))

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

((lambda()
   (define e '(cons z x))
   (define table '(((x y)
            ((a b c) (d e f)))
           ((u v w)
            (1 2 3))
           ((x y z)
            (4 5 6))))
   (meaning e table)
   ))
((lambda()
   (define args '(z x))
   (define table '(((x y)
            ((a b c) (d e f)))
           ((u v w)
            (1 2 3))
           ((x y z)
            (4 5 6))))
   (evlis args table)
   ))