Name: Anonymous 2012-04-24 8:20
What do you guys think about it ?
(define (lc-eval exp env)
; (display "ev ")(display exp)(newline)
(cond ((not (pair? exp)) (lookup-symbol exp env))
((lambda? exp) (make-lambda (lambda-arg exp)
(lc-eval (lambda-body exp)
(add-binding (lambda-arg exp)
(lambda-arg exp)
env))))
((application? exp) (lc-apply (lc-eval (operator exp) env)
(lc-eval (operands exp) env)
env))
((definition? exp) (set! global-env (add-binding (def-symbol exp)
(lc-eval (def-value exp) env)
global-env))
(list 'set (def-symbol exp) (lookup-symbol (def-symbol exp) global-env)))
(else (error "cannot eval " exp))))
(define (lc-apply exp arg env)
; (display "ap ")(display exp)(display " to ")(display arg)(newline)
(if (lambda? exp)
(lc-eval (lambda-body exp)
(add-binding (lambda-arg exp) arg env))
(make-application exp arg)))
(define (make-application exp arg)
(list exp arg))
(define (make-lambda arg body)
(list 'λ arg body))
;(define error (lambda message
; (map display message)
; (newline)
; 'undefined))
(define operator car)
(define operands cadr)
(define lambda-body caddr)
(define lambda-arg cadr)
(define def-symbol cadr)
(define def-value caddr)
(define (list-of-n? l n)
(and (list? l)
(= (length l) n)))
(define (any-symbol? exp)
(or (symbol? exp) (number? exp)))
(define (lambda? exp)
(and (list-of-n? exp 3) (any-symbol? (cadr exp))
(equal? (car exp) 'λ)))
(define (application? exp) (list-of-n? exp 2))
(define (definition? exp)
(and (list-of-n? exp 3) (any-symbol? (cadr exp))
(equal? (car exp) 'set)))
(define (empty-env) (list))
(define (add-binding symbol value env)
(cons (cons symbol value) env))
(define binding-symbol caar)
(define binding-value cdar)
(define parent-env cdr)
(define (lookup-symbol symbol env)
(cond ((null? env) (error "unbound variable " symbol))
((equal? symbol (binding-symbol env)) (binding-value env))
(else (lookup-symbol symbol (parent-env env)))))
(define env-with (lambda bindings
(if (null? bindings)
(empty-env)
(add-binding (caar bindings) (cadar bindings)
(apply env-with (cdr bindings))))))
(define global-env (empty-env))
; code here
; largely copied and inspired from http://en.wikipedia.org/wiki/Lambda_calculus#Arithmetic_in_lambda_calculus
(define code (quote ((set 1+ (λ n (λ f (λ x (f ((n f) x))))))
(set + (λ m (λ n (λ f (λ x ((m f) ((n f) x)))))))
(set * (λ m (λ n (λ f (m (n f))))))
(set I (λ x x))
(set K (λ x (λ y x)))
(set S (λ x (λ y (λ z ((x z) (y z))))))
(set ω (λ x (x x)))
; both these hang indefinitely:
;(set Ω (ω ω))
;(set Y (λ g ((λ x (g (x x))) (λ x (g (x x))))))
; numbers, calculated in many different ways
(set 0 (λ f (λ x x)))
(set 1 (1+ 0))
(set 2 (1+ 1))
(set 3 (λ f (λ x (f (f (f x))))))
(set 4 (1+ (1+ (1+ 1))))
(set 5 ((+ 2) 3))
(set 6 ((* 2) 3))
(set 7 ((+ 1) ((* 2) 3)))
(set true (λ x (λ y x)))
(set false (λ x (λ y y)))
(set if (λ p (λ a (λ b ((p a) b)))))
(set cons (λ a (λ b (λ p (((if p) a) b)))))
(set car (λ p (p true)))
(set cdr (λ p (p false)))
(set nil (λ x true))
(set null? (λ p (p (λ x (λ y false)))))
(car ((cons 0) 1))
(cdr ((cons 0) 1))
)))
(begin (map (lambda (e) (display (lc-eval e global-env))(newline)) code) 'done)
(define (loop)
(let ((e (read)))
(if (eof-object? e)
'done
(begin
(display (lc-eval e global-env))
(newline)
(loop)))))
(loop)