| (define atom?
(lambda (x)
(and (not (pair? x))
(not (null? x))))) (define add1
(lambda (n)
(+ n 1))) (define sub1
(lambda (n)
(- n 1))) (define first
(lambda (p)
(car p))) (define second
(lambda (p)
(cadr p))) (define third
(lambda (p)
(caddr p))) (define build
(lambda (s1 s2)
(cons s1 (cons s2 '())))) (define new-entry
(lambda (names values)
(build names values))) (define extend-table
(lambda (entry table)
(cons entry table))) (define text-of
(lambda (sexp)
(second sexp))) (define table-of
(lambda (sexp)
(first sexp))) (define formals-of
(lambda (sexp)
(second sexp))) (define body-of
(lambda (sexp)
(third sexp))) (define question-of
(lambda (sexp)
(first sexp))) (define answer-of
(lambda (sexp)
(second sexp))) (define cond-lines-of
(lambda (sexp)
(cdr sexp))) (define function-of
(lambda (sexp)
(car sexp))) (define arguments-of
(lambda (sexp)
(cdr sexp))) (define primitive?
(lambda (l)
(eq? (first l) 'primitive))) (define non-primitive?
(lambda (l)
(eq? (first l) 'non-primitive))) (define else?
(lambda (x)
(eq? x 'else))) (define lookup-in-entry
(lambda (name entry entry-f)
(lookup-in-entry-help name
(first entry)
(second entry)
entry-f))) (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 lookup-in-table
(lambda (name table table-f)
(if (null? table)
(table-f name)
(lookup-in-entry name
(car table)
(lambda (name)
(lookup-in-table name
(cdr table)
table-f)))))) (define expression-to-action
(lambda (e)
(if (atom? e)
(atom-to-action e)
(list-to-action e)))) (define atom-to-action
(lambda (e)
(cond ((number? e) *const)
((eq? e #t) *const)
((eq? e #f) *const)
((eq? e 'cons) *const)
((eq? e 'car) *const)
((eq? e 'cdr) *const)
((eq? e 'null?) *const)
((eq? e 'eq?) *const)
((eq? e 'atom?) *const)
((eq? e 'zero?) *const)
((eq? e 'add1) *const)
((eq? e 'sub1) *const)
((eq? e 'number?) *const)
(else *identifer)))) (define list-to-action
(lambda (e)
(let ((op (car e)))
(if (atom? op)
(cond ((eq? op 'quote) *quote)
((eq? op 'lambda) *lambda)
((eq? op 'cond) *cond)
(else *application))
*application)))) (define value
(lambda (e)
(meaning e '()))) (define meaning
(lambda (e table)
((expression-to-action e) e table))) (define initial-table
(lambda (name)
(car '()))) (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 *identifer
(lambda (e table)
(lookup-in-table e table initial-table))) (define *lambda
(lambda (e table)
(build 'non-primitive
(cons table (cdr e))))) (define evcon
(lambda (lines table)
(let ((front (car lines)))
(cond ((else? (question-of front))
(meaning (answer-of front) table))
((meaning (question-of front) table)
(meaning (answer-of front) table))
(else (evcon (cdr lines) table)))))) (define *cond
(lambda (e table)
(evcon (cond-lines-of e) table))) (define evlis
(lambda (args table)
(if (null? args)
'()
(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 *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)
(let ((fst (first vals))
(eqn? (lambda (q)
(eq? name q))))
(cond ((eqn? 'car) (car fst))
((eqn? 'cdr) (cdr fst))
((eqn? 'null?) (null? fst))
((eqn? 'atom?) (*atom? fst))
((eqn? 'zero?) (zero? fst))
((eqn? 'add1) (add1 fst))
((eqn? 'sub1) (sub1 fst))
((eqn? 'number?) (number? fst))
((eqn? 'cons) (cons fst (second vals)))
((eqn? 'eq?) (eq? fst (second vals))))))) (define *atom?
(lambda (x)
(cond ((atom? x) #t)
((null? x) #f)
((eq? (car x) 'primitve) #t)
((eq? (car x) 'non-primitive) #f)
(else #f)))) (define apply-closure
(lambda (closure vals)
(meaning (body-of closure)
(extend-table (new-entry (formals-of closure) vals)
(table-of closure))))) | 
0 件のコメント:
コメントを投稿