Naoaki Iwakiri/Scheme課題memo
(define (base-eval exp env)
(define (var-eval exp env)
(cdr (lookup-var exp env)))
(define (lambda-eval exp env)
(if (pair? (cdr exp))
(cons '*lambda* (cons env (cdr exp)))
(eval-error 'syntax-error exp)))
(define (def-eval exp env)
(define-var! (cadr exp) (if (list? (caddr exp)) (base-eval (caddr exp) env) (caddr exp)) env))
(define (if-eval exp env)
(if (base-eval (car (cdr exp)) env)
(base-eval (car (cdr (cdr exp))) env)
(base-eval (car (cdr (cdr (cdr exp)))) env)))
(define (let-eval exp env)
(let ((alist (cadr exp)))
(base-eval (cons (cons 'lambda (cons (map car alist) (cddr exp)))
(map cadr alist))
env)))
(define (quote-eval exp env)
(cadr exp));; really?
(define (app-eval exp env)
(let* ((l (map (lambda (exp) (base-eval exp env)) exp))
(fun (car l))
(args (cdr l)))
(base-apply fun args env)))
(define (base-apply fun args env)
(define (makeargs list symbols args); make a list like let form's first arg for environment extention
(cond ((null? symbols) list)
(#t (makeargs (cons (cons (car symbols) (car args)) list) (cdr symbols) (cdr args)))))
(cond ((not (pair? fun))
(eval-error 'non-function fun))
((equal? (car fun) '*lambda*)
(if (= (length (caddr fun)) (length args))
(begin
(let ((arglist (makeargs () (caddr fun) args)))
(let ((newenv (extend-env arglist (cadr fun))))
;; newenvを参照して、function内部のシンボル解決するように
(base-eval (cadddr fun) newenv))))
(eval-error 'wrong-number-of-args fun)))
((equal? (car fun) '*primitive*)
(if (or (not (number? (cadr fun))) (= (cadr fun) (length args)))
((caddr fun) args env)
(eval-error 'wrong-number-of-args fun)))
(#t
(eval-error 'non-function fun))))
(define (let-eval exp env)
(let ((alist (cadr exp)))
(base-eval (cons (cons 'lambda (cons (map car alist) (cddr exp)))
(map cadr alist))
env)))
(cond ((eof-object? exp) '*exit*)
((boolean? exp) exp)
((number? exp) exp)
((string? exp) exp)
((symbol? exp) (var-eval exp env))
((null? exp) exp)
((not (list? exp)) (eval-error 'syntax-error exp))
((equal? (car exp) 'exit) '*exit*)
;; ((equal? (car exp) 'begin
((equal? (car exp) 'lambda) (lambda-eval exp env))
((equal? (car exp) 'let) (let-eval exp env))
((equal? (car exp) 'define) (def-eval exp env))
;; ((equal? (car exp) 'letrec)
((equal? (car exp) 'if) (if-eval exp env))
((equal? (car exp) 'quote) (quote-eval exp env))
(#t (app-eval exp env))))