SICP 読み (159) 4.1.2 式の表現
4.10 をなんとなく動作確認。なんとなく動いた。試験はもう少しきちんと検討した方が良さげですが、稼働が上がってきたのでコマカい事に手を出さずにがんがん進めていかないと年内読了は不可能。
とりあえず、現時点での実装が以下。
(define apply-in-underlying-scheme apply)
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
#f))
(define (apply procedure arguments)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure procedure arguments))
((compound-procedure? procedure)
(eval-sequence
(procedure-body procedure)
(extend-environment
(procedure-parameters procedure)
arguments
(procedure-environment procedure))))
(else
(error "Unknown procedure type -- APPLY" procedure))))
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
#f))
#f)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (make-begin seq) (cons 'begin seq))
(define (install-quote)
(define (eval-quote exp env)
(cadr exp))
(put 'quote 'eval eval-quote)
'done)
(define (install-assignment)
(define (assignment-variable exp)
(cadr exp))
(define (assignment-value exp)
(caddr exp))
(define (eval-assignment exp env)
(set-variable-value! (assignment-variable exp)
(eval (assignment-value exp) env)
env))
(put 'set! 'eval eval-assignment)
'done)
(define (install-definition)
(define (definition-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp)))
(define (definition-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp)
(cddr exp))))
(define (eval-definition exp env)
(define-variable! (definition-variable exp)
(eval (definition-value exp) env)
env))
(put 'define 'eval eval-definition)
'done)
(define (install-if)
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (not (null? (cdddr exp)))
(cadddr exp)
'false))
(define (eval-if exp env)
(if (true? (eval (if-predicate exp) env))
(eval (if-consequent exp) env)
(eval (if-alternative exp) env)))
(put 'if 'eval eval-if)
'done)
(define (install-lambda)
(define (lambda-parameters exp)
(cadr exp))
(define (lambda-body exp)
(cddr exp))
(define (eval-lambda exp env)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
(put 'lambda 'eval eval-lambda)
'done)
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (eval-sequence exps env)
(cond ((last-exp? exps) (eval (first-exp exps) env))
(else (eval (first-exp exps) env)
(eval-sequence (rest-exps exps) env))))
(define (install-begin)
(define (begin-actions exp)
(cdr exp))
(define (eval-begin exp env)
(eval-sequence (begin-actions exp) env))
(put 'begin 'eval eval-begin)
'done)
(define (install-cond)
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clause? clause)
(eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (expand-clauses clauses)
(if (null? clauses)
'false
(let ((first (car clauses))
(rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error "ELSE clause isn't last -- COND->IF" clauses))
(make-if (cond-predicate first)
(if (equal? '=> (cadr first))
(list (caddr first) (cond-predicate first))
(sequence->exp (cond-actions first)))
(expand-clauses rest))))))
(define (sequence->exp seq)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(else (make-begin seq))))
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (eval-cond exp env)
(eval (cond->if exp) env))
(put 'cond 'eval eval-cond)
'done)
(define (install-and)
(define (eval-and exp env)
(define (eval-and-iter predicates env)
(let ((ret (eval (car predicates) env)))
(if (false? ret)
#f
(if (null? (cdr predicates))
ret
(eval-and-iter (cdr predicates) env)))))
(if (null? (cdr exp))
#t
(eval-and-iter (cdr exp) env)))
(put 'and 'eval eval-and)
'done)
(define (install-not)
(define (eval-not exp env)
(if (false? (eval (cadr exp) env))
#t
#f))
(put 'not 'eval eval-not)
'done)
(define (install-or)
(define (eval-or exp env)
(define (eval-or-iter predicates env)
(let ((ret (eval (car predicates) env)))
(if (true? ret)
ret
(if (null? (cdr predicates))
#f
(eval-or-iter (cdr predicates) env)))))
(if (null? (cdr exp))
#f
(eval-or-iter (cdr exp) env)))
(put 'or 'eval eval-or)
'done)
(define (install-let*)
(define (eval-let* exp env)
(eval (let*->nested-let exp) env))
(define (let*->nested-let exp)
(define (let*->nested-let-iter arg)
(cond ((null? arg) (caddr exp))
(else
(list 'let (list (car arg)) (let*->nested-let-iter (cdr arg))))))
(let*->nested-let-iter (cadr exp)))
(put 'let* 'eval eval-let*)
'done)
(define (install-let)
(define (eval-let exp env)
(eval (let->combination exp) env))
(define (let->combination exp)
(if (symbol? (cadr exp))
(list 'begin
(list 'define
(cadr exp)
(make-lambda (map car (caddr exp)) (cdddr exp)))
(append (list (cadr exp)) (map cadr (caddr exp))))
(append (list (make-lambda (map car (cadr exp)) (cddr exp)))
(map cadr (cadr exp)))))
(put 'let 'eval eval-let)
'done)
(define (eval exp env)
(define (list-of-values exps env)
(if (no-operands? exps)
'()
(cons (eval (first-operand exps) env)
(list-of-values (rest-operands exps) env))))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
(define (self-evaluating? exp)
(cond ((number? exp) #t)
((string? exp) #t)
(else #f)))
(define (variable? exp) (symbol? exp))
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((not (pair? exp))
(error "Unknown expression type -- EVAL" exp))
(else
(let ((x (get (car exp) 'eval)))
(if x
(x exp env)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))))))
(define (true? x)
(not (eq? x #f)))
(define (false? x)
(eq? x #f))
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (compound-procedure? p)
(tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())
(define (make-frame variables values)
(cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
(set-car! frame (cons var (car frame)))
(set-cdr! frame (cons val (cdr frame))))
(define (extend-environment vars vals base-env)
(if (= (length vars) (length vals))
(cons (make-frame vars vals) base-env)
(if (< (length vars) (length vals))
(error "Too many arguments supplied" vars vals)
(error "Too few arguments supplied" vars vals))))
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(car vals))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (set-variable-value! var val env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable -- SET!" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (define-variable! var val env)
(let ((frame (first-frame env)))
(define (scan vars vals)
(cond ((null? vars)
(add-binding-to-frame! var val frame))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(scan (frame-variables frame)
(frame-values frame))))
(define (primitive-procedure? proc)
(tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define primitive-procedures
(list (list 'car car)
(list 'cdr cdr)
(list 'cons cons)
(list 'null? null?)
(list 'list list)
(list 'eqv? eqv?)
(list 'eq? eq?)
(list 'equal? equal?)
(list 'number? number?)
(list 'complex? complex?)
(list 'real? real?)
(list 'rational? rational?)
(list 'integer? integer?)
(list '= =)
(list '< <)
(list '> >)
(list '<= <=)
(list '>= >=)
(list 'zero? zero?)
(list 'positive? positive?)
(list 'negative? negative?)
(list 'odd? odd?)
(list 'even? even?)
(list 'max max)
(list 'min min)
(list '+ +)
(list '* *)
(list '- -)
(list '/ /)
(list 'assoc assoc)
(list 'cadr cadr)
(list 'cddr cddr)
(list 'caddr caddr)
(list 'cdddr cdddr)
; <more primitives>
))
(define (primitive-procedure-names)
(map car
primitive-procedures))
(define (primitive-procedure-objects)
(map (lambda (proc) (list 'primitive (cadr proc)))
primitive-procedures))
(define (apply-primitive-procedure proc args)
(apply-in-underlying-scheme
(primitive-implementation proc) args))
(define (setup-environment)
(let ((initial-env
(extend-environment (primitive-procedure-names)
(primitive-procedure-objects)
the-empty-environment)))
(define-variable! 'true #t initial-env)
(define-variable! 'false #f initial-env)
(install-quote)
(install-assignment)
(install-definition)
(install-if)
(install-lambda)
(install-begin)
(install-cond)
(install-and)
(install-or)
(install-not)
(install-let)
(install-let*)
initial-env))
(define the-global-environment (setup-environment))setup-environment 手続きで install しちゃってるあたりは愛敬とゆー事で (何
それにしても scheme を scheme で書くのはある程度簡単なんでしょうが、他の言語で記述するのはとってもホネなんでしょうねぇ。いくつか思い当たるフシはあるんですが略。
