Racket 自评球拍解释器
我一直在尝试编写一个能够自我评估的球拍解释器，但由于某些原因，我无法让它工作。Racket 自评球拍解释器,racket,interpreter,evaluator,Racket,Interpreter,Evaluator,我一直在尝试编写一个能够自我评估的球拍解释器，但由于某些原因，我无法让它工作。解释器.rkt的代码非常标准。解释器测试.rkt中的代码可能是问题所在？我不确定 解释器.rkt #lang racket (provide eeval) (define (eeval lines) ; returns (key . val) if key in frame, #f otherwise (define (lookup-in-frame key frame) (cond [
解释器.rkt解释器测试.rkt解释器.rkt#lang racket
(provide eeval)
(define (eeval lines)
; returns (key . val) if key in frame, #f otherwise
(define (lookup-in-frame key frame)
(cond
[(null? frame) #f]
[(eq? key (mcar (mcar frame))) (mcar frame)]
[else (lookup-in-frame key (mcdr frame))]))
; returns (key . val) if key in env, #f otherwise
(define (lookup-in-env key env)
(cond
[(null? env) #f]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
key-val-pair
(lookup-in-env key (mcdr env))))]))
(define (add-to-env! key value env)
(set-mcar! env
(mcons (mcons key value)
(mcar env))))
(define (update-env! key value env)
(cond
[(null? env)
(error "set!: assignment disallowed; cannot set variable before its definition \nvariable:" key)]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
(set-mcdr! key-val-pair value)
(update-env! key value (mcdr env))))]))
(define (extend-env keys values env)
(define (new-frame keys values)
(cond
((null? keys) '())
(else (mcons (mcons (car keys) (car values))
(new-frame (cdr keys) (cdr values))))))
(mcons (new-frame keys values) env))
(define global-env (mcons '() '()))
(define (myeval expr env)
(cond
[(and (not (null? expr)) (not (pair? expr)))
(cond
[(boolean? expr) expr]
[(number? expr) expr]
[(string? expr) expr]
[(symbol? expr)
(let ([key-value (lookup-in-env expr env)])
(if key-value
[mcdr key-value]
[if [member expr
'(void void? null? member
pair? list cons car cdr cddr
mpair? mcons mcar mcdr
set-mcar! set-mcdr!
first second third fourth
boolean? false? not
number? = + - * / expt
string?
symbol? eq? equal?
foldl error)]
[lambda () (list 'primitive expr)]
[error expr "undefined"]]))])]
[(null? expr) (error "()" "missing procedure expression.")]
[(eq? (car expr) 'quote)
(second expr)]
[(eq? (car expr) 'lambda)
(lambda () (list 'non-primitive
(second expr)
(cddr expr)
env))]
[(eq? (car expr) 'define)
(if [not (pair? (second expr))]
[if [false? (lookup-in-frame (second expr) (mcar env))]
[add-to-env! (second expr) (myeval (third expr) env) env]
[error "duplicate definition for identifier in"
(second expr)]]
[myeval (list 'define
(car (second expr))
(cons 'lambda
(cons (cdr (second expr))
(cddr expr))))
env])]
[(eq? (car expr) 'set!)
(update-env! (second expr)
(myeval (third expr) env)
env)]
[(eq? (car expr) 'begin)
(eval-sequence (cdr expr) env)]
[(eq? (car expr) 'cond)
(evcond (cdr expr) env)]
[(eq? (car expr) 'if)
(myeval (list 'cond
(list (second expr) (third expr))
(list 'else (fourth expr)))
env)]
[(eq? (car expr) 'and) (evand (cdr expr) env)]
[(eq? (car expr) 'or) (evor (cdr expr) env)]
[(eq? (car expr) 'let)
(eval-sequence (cddr expr)
(extend-env
(map first (second expr))
(map second (second expr))
env))]
[else (myapply (myeval (car expr) env)
(eval-args (cdr expr) env))]
))
(define (eval-sequence lines env)
(if [null? lines]
[void]
(if [null? (cdr lines)]
[myeval (car lines) env]
[begin (myeval (car lines) env)
(eval-sequence (cdr lines) env)])))
(define (evcond lines env)
(cond
[(null? lines) (void)]
[(eq? 'else (first (car lines)))
(myeval (second (car lines)) env)]
[(myeval (first (car lines)) env)
(myeval (second (car lines)) env)]
[else (evcond (cdr lines) env)]))
(define (evand args env)
(cond
[(null? args) #t]
[(null? (cdr args)) (myeval (car args) env)]
[else [let ([val (myeval (car args) env)])
(if [false? val]
#f
[evand (cdr args) env])]]))
(define (evor args env)
(if [null? args]
#f
[let ([val (myeval (car args) env)])
(if val
val
(evor (cdr args) env))]))
(define (eval-args args env)
(cond
[(null? args) '()]
[else (cons (myeval (car args) env)
(eval-args (cdr args) env))]))
(define (myapply func vals)
(cond
[(eq? (first (func)) 'primitive)
(apply-primitive (second (func)) vals)]
[(eq? (first (func)) 'non-primitive)
(eval-sequence (third (func))
(extend-env
(second (func))
vals
(fourth (func))))]
[else (error func "unexpected case in myapply")]))
(define (apply-primitive name vals)
(cond
[(eq? name 'void) (void)]
[(eq? name 'void?) (void? (first vals))]
[(eq? name 'null?) (null? (first vals))]
[(eq? name 'member) (member (first vals) (second vals))]
[(eq? name 'pair?) (pair? (first vals))]
[(eq? name 'list)
(begin
(define (helper vals)
(if [null? vals]
'()
[cons (car vals) (helper (cdr vals))]))
(helper vals))]
[(eq? name 'cons) (cons (first vals) (second vals))]
[(eq? name 'car) (car (first vals))]
[(eq? name 'cdr) (cdr (first vals))]
[(eq? name 'cddr) (cddr (first vals))]
[(eq? name 'mpair?) (mpair? (first vals))]
[(eq? name 'mcons) (mcons (first vals) (second vals))]
[(eq? name 'mcar) (mcar (first vals))]
[(eq? name 'mcdr) (mcdr (first vals))]
[(eq? name 'set-mcar!) (set-mcar! (first vals) (second vals))]
[(eq? name 'set-mcdr!) (set-mcdr! (first vals) (second vals))]
[(eq? name 'first) (first (first vals))]
[(eq? name 'second) (second (first vals))]
[(eq? name 'third) (third (first vals))]
[(eq? name 'fourth) (fourth (first vals))]
[(eq? name 'boolean?) (boolean? (first vals))]
[(eq? name 'false?) (false? (first vals))]
[(eq? name 'not) (not (first vals))]
[(eq? name 'number?) (number? (first vals))]
[(eq? name '=)
(begin
(define (helper x l)
(cond
[(null? l) #t]
[(= (car l) x) (helper x (cdr l))]
[else #f]))
(if [or (null? vals)
(null? (cdr vals))]
[error "="
"arity mismatch; expects at least 2 arguments."]
[helper (car vals) (cdr vals)]))]
[(eq? name '+) (foldl + 0 vals)]
[(eq? name '-) (- (car vals) (foldl + 0 (cdr vals)))]
[(eq? name '*) (foldl * 1 vals)]
[(eq? name '/) (/ (car vals) (foldl * 1 (cdr vals)))]
[(eq? name 'expt) (expt (first vals) (second vals))]
[(eq? name 'string?) (string? (first vals))]
[(eq? name 'symbol?) (symbol? (first vals))]
[(eq? name 'eq?) (eq? (first vals) (second vals))]
[(eq? name 'equal?) (equal? (first vals) (second vals))]
[(eq? name 'foldl) (foldl (first vals)
(second vals)
(third vals))]
[(eq? name 'error) (error (first vals) (second vals))]))
(eval-sequence lines global-env)
)
(eeval
'(
(define (even? n)
(if [= n 0]
#t
[odd? (- n 1)]))
(define (odd? n)
(if [= n 0]
#f
[even? (- n 1)]))
(define x #f)
(set! x (even? 6))
x
))
#lang racket
(require "interpreter.rkt")
(eeval
'(
(define (eeval lines) ... ) ;; copy paste code from interpreter.rkt
))
#lang R5RS
(#%provide eeval)
(define (eeval lines)
(define first car)
(define second cadr)
(define third caddr)
(define fourth cadddr)
(define (foldl proc init lst)
(cond
((null? lst) init)
(else (foldl proc (proc (car lst) init) (cdr lst)))))
; returns (key . val) if key in frame, #f otherwise
(define (lookup-in-frame key frame)
(cond
((null? frame) #f)
((eq? key (car (car frame))) (car frame))
(else (lookup-in-frame key (cdr frame)))))
; returns (key . val) if key in env, #f otherwise
(define (lookup-in-env key env)
(cond
((null? env) #f)
(else (let ((key-val-pair (lookup-in-frame key (car env))))
(if key-val-pair
key-val-pair
(lookup-in-env key (cdr env)))))))
(define (add-to-env! key value env)
(set-car! env
(cons (cons key value)
(car env))))
(define (update-env! key value env)
(cond
((null? env)
(myerror "set!: assignment disallowed; cannot set variable before its definition \nvariable:" key))
(else (let ((key-val-pair (lookup-in-frame key (car env))))
(if key-val-pair
(set-cdr! key-val-pair value)
(update-env! key value (cdr env)))))))
(define (extend-env keys values env)
(define (new-frame keys values)
(cond
((null? keys) '())
(else (cons (cons (car keys) (car values))
(new-frame (cdr keys) (cdr values))))))
(cons (new-frame keys values) env))
(define global-env (cons '() '()))
(define (myeval expr env)
(cond
((and (not (null? expr)) (not (pair? expr)))
(cond
((boolean? expr) expr)
((number? expr) expr)
((string? expr) expr)
((symbol? expr)
(let ((key-value (lookup-in-env expr env)))
(if key-value
(cdr key-value)
(if (member expr
'(member null? pair?
list cons car cdr cddr
set-car! set-cdr!
cadr caddr cadddr
boolean? not
number? = + - * / expt
string?
symbol? eq? equal?
display))
(lambda () (list 'primitive expr))
(myerror expr "undefined")))))))
((null? expr) (myerror "()" "missing procedure expression."))
((eq? (car expr) 'quote)
(second expr))
((eq? (car expr) 'lambda)
(lambda () (list 'non-primitive
(second expr)
(cddr expr)
env)))
((eq? (car expr) 'define)
(if (not (pair? (second expr)))
(if (lookup-in-frame (second expr) (car env))
(myerror "duplicate definition for identifier in"
(second expr))
(add-to-env! (second expr) (myeval (third expr) env) env))
(myeval (list 'define
(car (second expr))
(cons 'lambda
(cons (cdr (second expr))
(cddr expr))))
env)))
((eq? (car expr) 'set!)
(update-env! (second expr)
(myeval (third expr) env)
env))
((eq? (car expr) 'begin)
(eval-sequence (cdr expr) env))
((eq? (car expr) 'cond)
(evcond (cdr expr) env))
((eq? (car expr) 'if)
(myeval (list 'cond
(list (second expr) (third expr))
(list 'else (fourth expr)))
env))
((eq? (car expr) 'and) (evand (cdr expr) env))
((eq? (car expr) 'or) (evor (cdr expr) env))
((eq? (car expr) 'let)
(eval-sequence (cddr expr)
(extend-env
(map first (second expr))
(map second (second expr))
env)))
(else (myapply (myeval (car expr) env)
(eval-args (cdr expr) env)))
))
(define (eval-sequence lines env)
(cond
((not (null? lines))
(if (null? (cdr lines))
(myeval (car lines) env)
(begin (myeval (car lines) env)
(eval-sequence (cdr lines) env))))))
(define (evcond lines env)
(cond
((not (null? lines))
(cond
((eq? 'else (first (car lines)))
(myeval (second (car lines)) env))
((myeval (first (car lines)) env)
(myeval (second (car lines)) env))
(else (evcond (cdr lines) env))))))
(define (evand args env)
(cond
((null? args) #t)
((null? (cdr args)) (myeval (car args) env))
(else (let ((val (myeval (car args) env)))
(if val
(evand (cdr args) env)
#f)))))
(define (evor args env)
(if (null? args)
#f
(let ((val (myeval (car args) env)))
(if val
val
(evor (cdr args) env)))))
(define (eval-args args env)
(cond
((null? args) '())
(else (cons (myeval (car args) env)
(eval-args (cdr args) env)))))
(define (myapply func vals)
(cond
((eq? (first (func)) 'primitive)
(apply-primitive (second (func)) vals))
((eq? (first (func)) 'non-primitive)
(eval-sequence (third (func))
(extend-env
(second (func))
vals
(fourth (func)))))
(else (myerror func "unexpected case in myapply"))))
(define (apply-primitive name vals)
(define (list-helper vals)
(if (null? vals)
'()
(cons (car vals) (list-helper (cdr vals)))))
(define (=helper x l)
(cond
((null? l) #t)
((= (car l) x) (=helper x (cdr l)))
(else #f)))
(cond
((eq? name 'member) (member (first vals) (second vals)))
((eq? name 'null?) (null? (first vals)))
((eq? name 'pair?) (pair? (first vals)))
((eq? name 'list) (list-helper vals))
((eq? name 'cons) (cons (first vals) (second vals)))
((eq? name 'car) (car (first vals)))
((eq? name 'cdr) (cdr (first vals)))
((eq? name 'cddr) (cddr (first vals)))
((eq? name 'set-car!) (set-car! (first vals) (second vals)))
((eq? name 'set-cdr!) (set-cdr! (first vals) (second vals)))
((eq? name 'cadr) (cadr (first vals)))
((eq? name 'caddr) (caddr (first vals)))
((eq? name 'cadddr) (cadddr (first vals)))
((eq? name 'boolean?) (boolean? (first vals)))
((eq? name 'not) (not (first vals)))
((eq? name 'number?) (number? (first vals)))
((eq? name '=)
(if (or (null? vals)
(null? (cdr vals)))
(myerror "="
"arity mismatch; expects at least 2 arguments.")
(=helper (car vals) (cdr vals))))
((eq? name '+) (foldl + 0 vals))
((eq? name '-) (- (car vals) (foldl + 0 (cdr vals))))
((eq? name '*) (foldl * 1 vals))
((eq? name '/) (/ (car vals) (foldl * 1 (cdr vals))))
((eq? name 'expt) (expt (first vals) (second vals)))
((eq? name 'string?) (string? (first vals)))
((eq? name 'symbol?) (symbol? (first vals)))
((eq? name 'eq?) (eq? (first vals) (second vals)))
((eq? name 'equal?) (equal? (first vals) (second vals)))
((eq? name 'display) (display (first vals)))
))
(define (myerror expr1 expr2)
(begin
(display expr1)
(display " ")
(display expr2)
(newline)))
(eval-sequence lines global-env)
)
(eeval
'(
(define (even? n)
(if (= n 0)
#t
(odd? (- n 1))))
(define (odd? n)
(if (= n 0)
#f
(even? (- n 1))))
(define x #f)
(set! x (even? 6))
(display x)
))
#lang R5RS
(#%require "interpreter-r5rs.rkt")
(eeval
'(
(define (eeval lines) ... ) ;; copy paste code from interpreter.rkt
))
#lang racket
(provide eeval)
(define (eeval lines)
;; The global environment is a mutable list of frames,
;; where each frame is a mutable list of
;; mutable variable-value pairs.
;; When a function is called, it creates a new frame
;; which is a mutable list of parameter-argument pairs.
;; Then it mcons the new frame to the enviroment the
;; function was defined in.
(define global-env (mcons '() '()))
; returns (mcons key val) if key in frame, #f otherwise
(define (lookup-in-frame key frame)
(cond
[(null? frame) #f]
[(eq? key (mcar (mcar frame))) (mcar frame)]
[else (lookup-in-frame key (mcdr frame))]))
; returns (mcons key val) if key in env, #f otherwise
(define (lookup-in-env key env)
(cond
[(null? env) #f]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
key-val-pair
(lookup-in-env key (mcdr env))))]))
(define (add-to-env! key value env)
(set-mcar! env
(mcons (mcons key value)
(mcar env))))
(define (update-env! key value env)
(cond
[(null? env)
(error "set!: assignment disallowed; cannot set variable before its definition \nvariable:" key)]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
(set-mcdr! key-val-pair value)
(update-env! key value (mcdr env))))]))
(define (extend-env keys values env)
(define (new-frame keys values)
(cond
((null? keys) '())
(else (mcons (mcons (car keys) (car values))
(new-frame (cdr keys) (cdr values))))))
(mcons (new-frame keys values) env))
(define (myeval expr env)
(cond
[(and (not (null? expr)) (not (pair? expr)))
(cond
[(boolean? expr) expr]
[(number? expr) expr]
[(string? expr) expr]
[(symbol? expr)
(let ([key-value (lookup-in-env expr env)])
(if key-value
[mcdr key-value]
[if [member expr
'(void void? null? member
pair? list cons car cdr cddr
mpair? mcons mcar mcdr
set-mcar! set-mcdr!
first second third fourth
boolean? false? not
number? = + - * / expt
string?
symbol? eq? equal?
display error)]
[lambda () (list 'primitive expr)]
[error expr "undefined"]]))])]
[(null? expr) (error "()" "missing procedure expression.")]
[(eq? (car expr) 'quote)
(second expr)]
[(eq? (car expr) 'lambda)
(lambda () (list 'non-primitive
(second expr)
(cddr expr)
env))]
[(eq? (car expr) 'define)
(if [not (pair? (second expr))]
[if [false? (lookup-in-frame (second expr) (mcar env))]
[add-to-env! (second expr) (myeval (third expr) env) env]
[error "duplicate definition for identifier in"
(second expr)]]
[myeval (list 'define
(car (second expr))
(cons 'lambda
(cons (cdr (second expr))
(cddr expr))))
env])]
[(eq? (car expr) 'set!)
(update-env! (second expr)
(myeval (third expr) env)
env)]
[(eq? (car expr) 'begin)
(eval-sequence (cdr expr) env)]
[(eq? (car expr) 'cond)
(evcond (cdr expr) env)]
[(eq? (car expr) 'if)
(myeval (list 'cond
(list (second expr) (third expr))
(list 'else (fourth expr)))
env)]
[(eq? (car expr) 'and) (evand (cdr expr) env)]
[(eq? (car expr) 'or) (evor (cdr expr) env)]
[(eq? (car expr) 'let)
(eval-sequence (cddr expr)
(extend-env
(map first (second expr))
(eval-args (map second (second expr)) env)
env))]
[else (myapply (myeval (car expr) env)
(eval-args (cdr expr) env))]
))
(define (eval-sequence lines env)
(if [null? lines]
[void]
(if [null? (cdr lines)]
[myeval (car lines) env]
[begin (myeval (car lines) env)
(eval-sequence (cdr lines) env)])))
(define (evcond lines env)
(cond
[(null? lines) (void)]
[(eq? 'else (first (car lines)))
(myeval (second (car lines)) env)]
[(myeval (first (car lines)) env)
(myeval (second (car lines)) env)]
[else (evcond (cdr lines) env)]))
(define (evand args env)
(cond
[(null? args) #t]
[(null? (cdr args)) (myeval (car args) env)]
[else [let ([val (myeval (car args) env)])
(if [false? val]
#f
[evand (cdr args) env])]]))
(define (evor args env)
(if [null? args]
#f
[let ([val (myeval (car args) env)])
(if val
val
(evor (cdr args) env))]))
(define (eval-args args env)
(cond
[(null? args) '()]
[else (cons (myeval (car args) env)
(eval-args (cdr args) env))]))
(define (myapply func vals)
(cond
[(eq? (first (func)) 'primitive)
(apply-primitive (second (func)) vals)]
[(eq? (first (func)) 'non-primitive)
(eval-sequence (third (func))
(extend-env
(second (func))
vals
(fourth (func))))]
[else (error func "unexpected case in myapply")]))
(define (apply-primitive name vals)
(cond
[(eq? name 'void) (void)]
[(eq? name 'void?) (void? (first vals))]
[(eq? name 'null?) (null? (first vals))]
[(eq? name 'member) (member (first vals) (second vals))]
[(eq? name 'pair?) (pair? (first vals))]
[(eq? name 'list)
(begin
(define (helper vals)
(if [null? vals]
'()
[cons (car vals) (helper (cdr vals))]))
(helper vals))]
[(eq? name 'cons) (cons (first vals) (second vals))]
[(eq? name 'car) (car (first vals))]
[(eq? name 'cdr) (cdr (first vals))]
[(eq? name 'cddr) (cddr (first vals))]
[(eq? name 'mpair?) (mpair? (first vals))]
[(eq? name 'mcons) (mcons (first vals) (second vals))]
[(eq? name 'mcar) (mcar (first vals))]
[(eq? name 'mcdr) (mcdr (first vals))]
[(eq? name 'set-mcar!) (set-mcar! (first vals) (second vals))]
[(eq? name 'set-mcdr!) (set-mcdr! (first vals) (second vals))]
[(eq? name 'first) (first (first vals))]
[(eq? name 'second) (second (first vals))]
[(eq? name 'third) (third (first vals))]
[(eq? name 'fourth) (fourth (first vals))]
[(eq? name 'boolean?) (boolean? (first vals))]
[(eq? name 'false?) (false? (first vals))]
[(eq? name 'not) (not (first vals))]
[(eq? name 'number?) (number? (first vals))]
[(eq? name '=)
(begin
(define (helper x l)
(cond
[(null? l) #t]
[(= (car l) x) (helper x (cdr l))]
[else #f]))
(if [or (null? vals)
(null? (cdr vals))]
[error "="
"arity mismatch; expects at least 2 arguments."]
[helper (car vals) (cdr vals)]))]
[(eq? name '+) (foldl + 0 vals)]
[(eq? name '-) (- (car vals) (foldl + 0 (cdr vals)))]
[(eq? name '*) (foldl * 1 vals)]
[(eq? name '/) (/ (car vals) (foldl * 1 (cdr vals)))]
[(eq? name 'expt) (expt (first vals) (second vals))]
[(eq? name 'string?) (string? (first vals))]
[(eq? name 'symbol?) (symbol? (first vals))]
[(eq? name 'eq?) (eq? (first vals) (second vals))]
[(eq? name 'equal?) (equal? (first vals) (second vals))]
; [(eq? name 'foldl) (foldl (first vals)
; (second vals)
; (third vals))]
((eq? name 'display) (display (first vals)))
[(eq? name 'error) (error (first vals) (second vals))]))
(define (foldl proc init lst)
(cond
((null? lst) init)
(else (foldl proc (proc (car lst) init) (cdr lst)))))
(define (eval-print-sequence lines)
(if [null? lines]
[void]
[let ([result (myeval (car lines) global-env)])
(if [void? result]
[eval-print-sequence (cdr lines)]
[begin (display result)
(display "\n")
(eval-print-sequence (cdr lines))])]))
(eval-print-sequence lines)
)
(eeval
'(
(define (even? n)
(if [= n 0]
#t
[odd? (- n 1)]))
(define (odd? n)
(if [= n 0]
#f
[even? (- n 1)]))
(define x #f)
(set! x (even? 6))
x
))
#t解释器测试.rkt#lang racket
(provide eeval)
(define (eeval lines)
; returns (key . val) if key in frame, #f otherwise
(define (lookup-in-frame key frame)
(cond
[(null? frame) #f]
[(eq? key (mcar (mcar frame))) (mcar frame)]
[else (lookup-in-frame key (mcdr frame))]))
; returns (key . val) if key in env, #f otherwise
(define (lookup-in-env key env)
(cond
[(null? env) #f]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
key-val-pair
(lookup-in-env key (mcdr env))))]))
(define (add-to-env! key value env)
(set-mcar! env
(mcons (mcons key value)
(mcar env))))
(define (update-env! key value env)
(cond
[(null? env)
(error "set!: assignment disallowed; cannot set variable before its definition \nvariable:" key)]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
(set-mcdr! key-val-pair value)
(update-env! key value (mcdr env))))]))
(define (extend-env keys values env)
(define (new-frame keys values)
(cond
((null? keys) '())
(else (mcons (mcons (car keys) (car values))
(new-frame (cdr keys) (cdr values))))))
(mcons (new-frame keys values) env))
(define global-env (mcons '() '()))
(define (myeval expr env)
(cond
[(and (not (null? expr)) (not (pair? expr)))
(cond
[(boolean? expr) expr]
[(number? expr) expr]
[(string? expr) expr]
[(symbol? expr)
(let ([key-value (lookup-in-env expr env)])
(if key-value
[mcdr key-value]
[if [member expr
'(void void? null? member
pair? list cons car cdr cddr
mpair? mcons mcar mcdr
set-mcar! set-mcdr!
first second third fourth
boolean? false? not
number? = + - * / expt
string?
symbol? eq? equal?
foldl error)]
[lambda () (list 'primitive expr)]
[error expr "undefined"]]))])]
[(null? expr) (error "()" "missing procedure expression.")]
[(eq? (car expr) 'quote)
(second expr)]
[(eq? (car expr) 'lambda)
(lambda () (list 'non-primitive
(second expr)
(cddr expr)
env))]
[(eq? (car expr) 'define)
(if [not (pair? (second expr))]
[if [false? (lookup-in-frame (second expr) (mcar env))]
[add-to-env! (second expr) (myeval (third expr) env) env]
[error "duplicate definition for identifier in"
(second expr)]]
[myeval (list 'define
(car (second expr))
(cons 'lambda
(cons (cdr (second expr))
(cddr expr))))
env])]
[(eq? (car expr) 'set!)
(update-env! (second expr)
(myeval (third expr) env)
env)]
[(eq? (car expr) 'begin)
(eval-sequence (cdr expr) env)]
[(eq? (car expr) 'cond)
(evcond (cdr expr) env)]
[(eq? (car expr) 'if)
(myeval (list 'cond
(list (second expr) (third expr))
(list 'else (fourth expr)))
env)]
[(eq? (car expr) 'and) (evand (cdr expr) env)]
[(eq? (car expr) 'or) (evor (cdr expr) env)]
[(eq? (car expr) 'let)
(eval-sequence (cddr expr)
(extend-env
(map first (second expr))
(map second (second expr))
env))]
[else (myapply (myeval (car expr) env)
(eval-args (cdr expr) env))]
))
(define (eval-sequence lines env)
(if [null? lines]
[void]
(if [null? (cdr lines)]
[myeval (car lines) env]
[begin (myeval (car lines) env)
(eval-sequence (cdr lines) env)])))
(define (evcond lines env)
(cond
[(null? lines) (void)]
[(eq? 'else (first (car lines)))
(myeval (second (car lines)) env)]
[(myeval (first (car lines)) env)
(myeval (second (car lines)) env)]
[else (evcond (cdr lines) env)]))
(define (evand args env)
(cond
[(null? args) #t]
[(null? (cdr args)) (myeval (car args) env)]
[else [let ([val (myeval (car args) env)])
(if [false? val]
#f
[evand (cdr args) env])]]))
(define (evor args env)
(if [null? args]
#f
[let ([val (myeval (car args) env)])
(if val
val
(evor (cdr args) env))]))
(define (eval-args args env)
(cond
[(null? args) '()]
[else (cons (myeval (car args) env)
(eval-args (cdr args) env))]))
(define (myapply func vals)
(cond
[(eq? (first (func)) 'primitive)
(apply-primitive (second (func)) vals)]
[(eq? (first (func)) 'non-primitive)
(eval-sequence (third (func))
(extend-env
(second (func))
vals
(fourth (func))))]
[else (error func "unexpected case in myapply")]))
(define (apply-primitive name vals)
(cond
[(eq? name 'void) (void)]
[(eq? name 'void?) (void? (first vals))]
[(eq? name 'null?) (null? (first vals))]
[(eq? name 'member) (member (first vals) (second vals))]
[(eq? name 'pair?) (pair? (first vals))]
[(eq? name 'list)
(begin
(define (helper vals)
(if [null? vals]
'()
[cons (car vals) (helper (cdr vals))]))
(helper vals))]
[(eq? name 'cons) (cons (first vals) (second vals))]
[(eq? name 'car) (car (first vals))]
[(eq? name 'cdr) (cdr (first vals))]
[(eq? name 'cddr) (cddr (first vals))]
[(eq? name 'mpair?) (mpair? (first vals))]
[(eq? name 'mcons) (mcons (first vals) (second vals))]
[(eq? name 'mcar) (mcar (first vals))]
[(eq? name 'mcdr) (mcdr (first vals))]
[(eq? name 'set-mcar!) (set-mcar! (first vals) (second vals))]
[(eq? name 'set-mcdr!) (set-mcdr! (first vals) (second vals))]
[(eq? name 'first) (first (first vals))]
[(eq? name 'second) (second (first vals))]
[(eq? name 'third) (third (first vals))]
[(eq? name 'fourth) (fourth (first vals))]
[(eq? name 'boolean?) (boolean? (first vals))]
[(eq? name 'false?) (false? (first vals))]
[(eq? name 'not) (not (first vals))]
[(eq? name 'number?) (number? (first vals))]
[(eq? name '=)
(begin
(define (helper x l)
(cond
[(null? l) #t]
[(= (car l) x) (helper x (cdr l))]
[else #f]))
(if [or (null? vals)
(null? (cdr vals))]
[error "="
"arity mismatch; expects at least 2 arguments."]
[helper (car vals) (cdr vals)]))]
[(eq? name '+) (foldl + 0 vals)]
[(eq? name '-) (- (car vals) (foldl + 0 (cdr vals)))]
[(eq? name '*) (foldl * 1 vals)]
[(eq? name '/) (/ (car vals) (foldl * 1 (cdr vals)))]
[(eq? name 'expt) (expt (first vals) (second vals))]
[(eq? name 'string?) (string? (first vals))]
[(eq? name 'symbol?) (symbol? (first vals))]
[(eq? name 'eq?) (eq? (first vals) (second vals))]
[(eq? name 'equal?) (equal? (first vals) (second vals))]
[(eq? name 'foldl) (foldl (first vals)
(second vals)
(third vals))]
[(eq? name 'error) (error (first vals) (second vals))]))
(eval-sequence lines global-env)
)
(eeval
'(
(define (even? n)
(if [= n 0]
#t
[odd? (- n 1)]))
(define (odd? n)
(if [= n 0]
#f
[even? (- n 1)]))
(define x #f)
(set! x (even? 6))
x
))
#lang racket
(require "interpreter.rkt")
(eeval
'(
(define (eeval lines) ... ) ;; copy paste code from interpreter.rkt
))
#lang R5RS
(#%provide eeval)
(define (eeval lines)
(define first car)
(define second cadr)
(define third caddr)
(define fourth cadddr)
(define (foldl proc init lst)
(cond
((null? lst) init)
(else (foldl proc (proc (car lst) init) (cdr lst)))))
; returns (key . val) if key in frame, #f otherwise
(define (lookup-in-frame key frame)
(cond
((null? frame) #f)
((eq? key (car (car frame))) (car frame))
(else (lookup-in-frame key (cdr frame)))))
; returns (key . val) if key in env, #f otherwise
(define (lookup-in-env key env)
(cond
((null? env) #f)
(else (let ((key-val-pair (lookup-in-frame key (car env))))
(if key-val-pair
key-val-pair
(lookup-in-env key (cdr env)))))))
(define (add-to-env! key value env)
(set-car! env
(cons (cons key value)
(car env))))
(define (update-env! key value env)
(cond
((null? env)
(myerror "set!: assignment disallowed; cannot set variable before its definition \nvariable:" key))
(else (let ((key-val-pair (lookup-in-frame key (car env))))
(if key-val-pair
(set-cdr! key-val-pair value)
(update-env! key value (cdr env)))))))
(define (extend-env keys values env)
(define (new-frame keys values)
(cond
((null? keys) '())
(else (cons (cons (car keys) (car values))
(new-frame (cdr keys) (cdr values))))))
(cons (new-frame keys values) env))
(define global-env (cons '() '()))
(define (myeval expr env)
(cond
((and (not (null? expr)) (not (pair? expr)))
(cond
((boolean? expr) expr)
((number? expr) expr)
((string? expr) expr)
((symbol? expr)
(let ((key-value (lookup-in-env expr env)))
(if key-value
(cdr key-value)
(if (member expr
'(member null? pair?
list cons car cdr cddr
set-car! set-cdr!
cadr caddr cadddr
boolean? not
number? = + - * / expt
string?
symbol? eq? equal?
display))
(lambda () (list 'primitive expr))
(myerror expr "undefined")))))))
((null? expr) (myerror "()" "missing procedure expression."))
((eq? (car expr) 'quote)
(second expr))
((eq? (car expr) 'lambda)
(lambda () (list 'non-primitive
(second expr)
(cddr expr)
env)))
((eq? (car expr) 'define)
(if (not (pair? (second expr)))
(if (lookup-in-frame (second expr) (car env))
(myerror "duplicate definition for identifier in"
(second expr))
(add-to-env! (second expr) (myeval (third expr) env) env))
(myeval (list 'define
(car (second expr))
(cons 'lambda
(cons (cdr (second expr))
(cddr expr))))
env)))
((eq? (car expr) 'set!)
(update-env! (second expr)
(myeval (third expr) env)
env))
((eq? (car expr) 'begin)
(eval-sequence (cdr expr) env))
((eq? (car expr) 'cond)
(evcond (cdr expr) env))
((eq? (car expr) 'if)
(myeval (list 'cond
(list (second expr) (third expr))
(list 'else (fourth expr)))
env))
((eq? (car expr) 'and) (evand (cdr expr) env))
((eq? (car expr) 'or) (evor (cdr expr) env))
((eq? (car expr) 'let)
(eval-sequence (cddr expr)
(extend-env
(map first (second expr))
(map second (second expr))
env)))
(else (myapply (myeval (car expr) env)
(eval-args (cdr expr) env)))
))
(define (eval-sequence lines env)
(cond
((not (null? lines))
(if (null? (cdr lines))
(myeval (car lines) env)
(begin (myeval (car lines) env)
(eval-sequence (cdr lines) env))))))
(define (evcond lines env)
(cond
((not (null? lines))
(cond
((eq? 'else (first (car lines)))
(myeval (second (car lines)) env))
((myeval (first (car lines)) env)
(myeval (second (car lines)) env))
(else (evcond (cdr lines) env))))))
(define (evand args env)
(cond
((null? args) #t)
((null? (cdr args)) (myeval (car args) env))
(else (let ((val (myeval (car args) env)))
(if val
(evand (cdr args) env)
#f)))))
(define (evor args env)
(if (null? args)
#f
(let ((val (myeval (car args) env)))
(if val
val
(evor (cdr args) env)))))
(define (eval-args args env)
(cond
((null? args) '())
(else (cons (myeval (car args) env)
(eval-args (cdr args) env)))))
(define (myapply func vals)
(cond
((eq? (first (func)) 'primitive)
(apply-primitive (second (func)) vals))
((eq? (first (func)) 'non-primitive)
(eval-sequence (third (func))
(extend-env
(second (func))
vals
(fourth (func)))))
(else (myerror func "unexpected case in myapply"))))
(define (apply-primitive name vals)
(define (list-helper vals)
(if (null? vals)
'()
(cons (car vals) (list-helper (cdr vals)))))
(define (=helper x l)
(cond
((null? l) #t)
((= (car l) x) (=helper x (cdr l)))
(else #f)))
(cond
((eq? name 'member) (member (first vals) (second vals)))
((eq? name 'null?) (null? (first vals)))
((eq? name 'pair?) (pair? (first vals)))
((eq? name 'list) (list-helper vals))
((eq? name 'cons) (cons (first vals) (second vals)))
((eq? name 'car) (car (first vals)))
((eq? name 'cdr) (cdr (first vals)))
((eq? name 'cddr) (cddr (first vals)))
((eq? name 'set-car!) (set-car! (first vals) (second vals)))
((eq? name 'set-cdr!) (set-cdr! (first vals) (second vals)))
((eq? name 'cadr) (cadr (first vals)))
((eq? name 'caddr) (caddr (first vals)))
((eq? name 'cadddr) (cadddr (first vals)))
((eq? name 'boolean?) (boolean? (first vals)))
((eq? name 'not) (not (first vals)))
((eq? name 'number?) (number? (first vals)))
((eq? name '=)
(if (or (null? vals)
(null? (cdr vals)))
(myerror "="
"arity mismatch; expects at least 2 arguments.")
(=helper (car vals) (cdr vals))))
((eq? name '+) (foldl + 0 vals))
((eq? name '-) (- (car vals) (foldl + 0 (cdr vals))))
((eq? name '*) (foldl * 1 vals))
((eq? name '/) (/ (car vals) (foldl * 1 (cdr vals))))
((eq? name 'expt) (expt (first vals) (second vals)))
((eq? name 'string?) (string? (first vals)))
((eq? name 'symbol?) (symbol? (first vals)))
((eq? name 'eq?) (eq? (first vals) (second vals)))
((eq? name 'equal?) (equal? (first vals) (second vals)))
((eq? name 'display) (display (first vals)))
))
(define (myerror expr1 expr2)
(begin
(display expr1)
(display " ")
(display expr2)
(newline)))
(eval-sequence lines global-env)
)
(eeval
'(
(define (even? n)
(if (= n 0)
#t
(odd? (- n 1))))
(define (odd? n)
(if (= n 0)
#f
(even? (- n 1))))
(define x #f)
(set! x (even? 6))
(display x)
))
#lang R5RS
(#%require "interpreter-r5rs.rkt")
(eeval
'(
(define (eeval lines) ... ) ;; copy paste code from interpreter.rkt
))
#lang racket
(provide eeval)
(define (eeval lines)
;; The global environment is a mutable list of frames,
;; where each frame is a mutable list of
;; mutable variable-value pairs.
;; When a function is called, it creates a new frame
;; which is a mutable list of parameter-argument pairs.
;; Then it mcons the new frame to the enviroment the
;; function was defined in.
(define global-env (mcons '() '()))
; returns (mcons key val) if key in frame, #f otherwise
(define (lookup-in-frame key frame)
(cond
[(null? frame) #f]
[(eq? key (mcar (mcar frame))) (mcar frame)]
[else (lookup-in-frame key (mcdr frame))]))
; returns (mcons key val) if key in env, #f otherwise
(define (lookup-in-env key env)
(cond
[(null? env) #f]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
key-val-pair
(lookup-in-env key (mcdr env))))]))
(define (add-to-env! key value env)
(set-mcar! env
(mcons (mcons key value)
(mcar env))))
(define (update-env! key value env)
(cond
[(null? env)
(error "set!: assignment disallowed; cannot set variable before its definition \nvariable:" key)]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
(set-mcdr! key-val-pair value)
(update-env! key value (mcdr env))))]))
(define (extend-env keys values env)
(define (new-frame keys values)
(cond
((null? keys) '())
(else (mcons (mcons (car keys) (car values))
(new-frame (cdr keys) (cdr values))))))
(mcons (new-frame keys values) env))
(define (myeval expr env)
(cond
[(and (not (null? expr)) (not (pair? expr)))
(cond
[(boolean? expr) expr]
[(number? expr) expr]
[(string? expr) expr]
[(symbol? expr)
(let ([key-value (lookup-in-env expr env)])
(if key-value
[mcdr key-value]
[if [member expr
'(void void? null? member
pair? list cons car cdr cddr
mpair? mcons mcar mcdr
set-mcar! set-mcdr!
first second third fourth
boolean? false? not
number? = + - * / expt
string?
symbol? eq? equal?
display error)]
[lambda () (list 'primitive expr)]
[error expr "undefined"]]))])]
[(null? expr) (error "()" "missing procedure expression.")]
[(eq? (car expr) 'quote)
(second expr)]
[(eq? (car expr) 'lambda)
(lambda () (list 'non-primitive
(second expr)
(cddr expr)
env))]
[(eq? (car expr) 'define)
(if [not (pair? (second expr))]
[if [false? (lookup-in-frame (second expr) (mcar env))]
[add-to-env! (second expr) (myeval (third expr) env) env]
[error "duplicate definition for identifier in"
(second expr)]]
[myeval (list 'define
(car (second expr))
(cons 'lambda
(cons (cdr (second expr))
(cddr expr))))
env])]
[(eq? (car expr) 'set!)
(update-env! (second expr)
(myeval (third expr) env)
env)]
[(eq? (car expr) 'begin)
(eval-sequence (cdr expr) env)]
[(eq? (car expr) 'cond)
(evcond (cdr expr) env)]
[(eq? (car expr) 'if)
(myeval (list 'cond
(list (second expr) (third expr))
(list 'else (fourth expr)))
env)]
[(eq? (car expr) 'and) (evand (cdr expr) env)]
[(eq? (car expr) 'or) (evor (cdr expr) env)]
[(eq? (car expr) 'let)
(eval-sequence (cddr expr)
(extend-env
(map first (second expr))
(eval-args (map second (second expr)) env)
env))]
[else (myapply (myeval (car expr) env)
(eval-args (cdr expr) env))]
))
(define (eval-sequence lines env)
(if [null? lines]
[void]
(if [null? (cdr lines)]
[myeval (car lines) env]
[begin (myeval (car lines) env)
(eval-sequence (cdr lines) env)])))
(define (evcond lines env)
(cond
[(null? lines) (void)]
[(eq? 'else (first (car lines)))
(myeval (second (car lines)) env)]
[(myeval (first (car lines)) env)
(myeval (second (car lines)) env)]
[else (evcond (cdr lines) env)]))
(define (evand args env)
(cond
[(null? args) #t]
[(null? (cdr args)) (myeval (car args) env)]
[else [let ([val (myeval (car args) env)])
(if [false? val]
#f
[evand (cdr args) env])]]))
(define (evor args env)
(if [null? args]
#f
[let ([val (myeval (car args) env)])
(if val
val
(evor (cdr args) env))]))
(define (eval-args args env)
(cond
[(null? args) '()]
[else (cons (myeval (car args) env)
(eval-args (cdr args) env))]))
(define (myapply func vals)
(cond
[(eq? (first (func)) 'primitive)
(apply-primitive (second (func)) vals)]
[(eq? (first (func)) 'non-primitive)
(eval-sequence (third (func))
(extend-env
(second (func))
vals
(fourth (func))))]
[else (error func "unexpected case in myapply")]))
(define (apply-primitive name vals)
(cond
[(eq? name 'void) (void)]
[(eq? name 'void?) (void? (first vals))]
[(eq? name 'null?) (null? (first vals))]
[(eq? name 'member) (member (first vals) (second vals))]
[(eq? name 'pair?) (pair? (first vals))]
[(eq? name 'list)
(begin
(define (helper vals)
(if [null? vals]
'()
[cons (car vals) (helper (cdr vals))]))
(helper vals))]
[(eq? name 'cons) (cons (first vals) (second vals))]
[(eq? name 'car) (car (first vals))]
[(eq? name 'cdr) (cdr (first vals))]
[(eq? name 'cddr) (cddr (first vals))]
[(eq? name 'mpair?) (mpair? (first vals))]
[(eq? name 'mcons) (mcons (first vals) (second vals))]
[(eq? name 'mcar) (mcar (first vals))]
[(eq? name 'mcdr) (mcdr (first vals))]
[(eq? name 'set-mcar!) (set-mcar! (first vals) (second vals))]
[(eq? name 'set-mcdr!) (set-mcdr! (first vals) (second vals))]
[(eq? name 'first) (first (first vals))]
[(eq? name 'second) (second (first vals))]
[(eq? name 'third) (third (first vals))]
[(eq? name 'fourth) (fourth (first vals))]
[(eq? name 'boolean?) (boolean? (first vals))]
[(eq? name 'false?) (false? (first vals))]
[(eq? name 'not) (not (first vals))]
[(eq? name 'number?) (number? (first vals))]
[(eq? name '=)
(begin
(define (helper x l)
(cond
[(null? l) #t]
[(= (car l) x) (helper x (cdr l))]
[else #f]))
(if [or (null? vals)
(null? (cdr vals))]
[error "="
"arity mismatch; expects at least 2 arguments."]
[helper (car vals) (cdr vals)]))]
[(eq? name '+) (foldl + 0 vals)]
[(eq? name '-) (- (car vals) (foldl + 0 (cdr vals)))]
[(eq? name '*) (foldl * 1 vals)]
[(eq? name '/) (/ (car vals) (foldl * 1 (cdr vals)))]
[(eq? name 'expt) (expt (first vals) (second vals))]
[(eq? name 'string?) (string? (first vals))]
[(eq? name 'symbol?) (symbol? (first vals))]
[(eq? name 'eq?) (eq? (first vals) (second vals))]
[(eq? name 'equal?) (equal? (first vals) (second vals))]
; [(eq? name 'foldl) (foldl (first vals)
; (second vals)
; (third vals))]
((eq? name 'display) (display (first vals)))
[(eq? name 'error) (error (first vals) (second vals))]))
(define (foldl proc init lst)
(cond
((null? lst) init)
(else (foldl proc (proc (car lst) init) (cdr lst)))))
(define (eval-print-sequence lines)
(if [null? lines]
[void]
[let ([result (myeval (car lines) global-env)])
(if [void? result]
[eval-print-sequence (cdr lines)]
[begin (display result)
(display "\n")
(eval-print-sequence (cdr lines))])]))
(eval-print-sequence lines)
)
(eeval
'(
(define (even? n)
(if [= n 0]
#t
[odd? (- n 1)]))
(define (odd? n)
(if [= n 0]
#f
[even? (- n 1)]))
(define x #f)
(set! x (even? 6))
x
))
#t（需要“interpreter.rkt”）（require“interpreter.rkt”）#t; mcdr: contract violation
; expected: mpair?
; given: '(lookup-in-env expr env)
解释器-r5rs.rkt#lang racket
(provide eeval)
(define (eeval lines)
; returns (key . val) if key in frame, #f otherwise
(define (lookup-in-frame key frame)
(cond
[(null? frame) #f]
[(eq? key (mcar (mcar frame))) (mcar frame)]
[else (lookup-in-frame key (mcdr frame))]))
; returns (key . val) if key in env, #f otherwise
(define (lookup-in-env key env)
(cond
[(null? env) #f]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
key-val-pair
(lookup-in-env key (mcdr env))))]))
(define (add-to-env! key value env)
(set-mcar! env
(mcons (mcons key value)
(mcar env))))
(define (update-env! key value env)
(cond
[(null? env)
(error "set!: assignment disallowed; cannot set variable before its definition \nvariable:" key)]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
(set-mcdr! key-val-pair value)
(update-env! key value (mcdr env))))]))
(define (extend-env keys values env)
(define (new-frame keys values)
(cond
((null? keys) '())
(else (mcons (mcons (car keys) (car values))
(new-frame (cdr keys) (cdr values))))))
(mcons (new-frame keys values) env))
(define global-env (mcons '() '()))
(define (myeval expr env)
(cond
[(and (not (null? expr)) (not (pair? expr)))
(cond
[(boolean? expr) expr]
[(number? expr) expr]
[(string? expr) expr]
[(symbol? expr)
(let ([key-value (lookup-in-env expr env)])
(if key-value
[mcdr key-value]
[if [member expr
'(void void? null? member
pair? list cons car cdr cddr
mpair? mcons mcar mcdr
set-mcar! set-mcdr!
first second third fourth
boolean? false? not
number? = + - * / expt
string?
symbol? eq? equal?
foldl error)]
[lambda () (list 'primitive expr)]
[error expr "undefined"]]))])]
[(null? expr) (error "()" "missing procedure expression.")]
[(eq? (car expr) 'quote)
(second expr)]
[(eq? (car expr) 'lambda)
(lambda () (list 'non-primitive
(second expr)
(cddr expr)
env))]
[(eq? (car expr) 'define)
(if [not (pair? (second expr))]
[if [false? (lookup-in-frame (second expr) (mcar env))]
[add-to-env! (second expr) (myeval (third expr) env) env]
[error "duplicate definition for identifier in"
(second expr)]]
[myeval (list 'define
(car (second expr))
(cons 'lambda
(cons (cdr (second expr))
(cddr expr))))
env])]
[(eq? (car expr) 'set!)
(update-env! (second expr)
(myeval (third expr) env)
env)]
[(eq? (car expr) 'begin)
(eval-sequence (cdr expr) env)]
[(eq? (car expr) 'cond)
(evcond (cdr expr) env)]
[(eq? (car expr) 'if)
(myeval (list 'cond
(list (second expr) (third expr))
(list 'else (fourth expr)))
env)]
[(eq? (car expr) 'and) (evand (cdr expr) env)]
[(eq? (car expr) 'or) (evor (cdr expr) env)]
[(eq? (car expr) 'let)
(eval-sequence (cddr expr)
(extend-env
(map first (second expr))
(map second (second expr))
env))]
[else (myapply (myeval (car expr) env)
(eval-args (cdr expr) env))]
))
(define (eval-sequence lines env)
(if [null? lines]
[void]
(if [null? (cdr lines)]
[myeval (car lines) env]
[begin (myeval (car lines) env)
(eval-sequence (cdr lines) env)])))
(define (evcond lines env)
(cond
[(null? lines) (void)]
[(eq? 'else (first (car lines)))
(myeval (second (car lines)) env)]
[(myeval (first (car lines)) env)
(myeval (second (car lines)) env)]
[else (evcond (cdr lines) env)]))
(define (evand args env)
(cond
[(null? args) #t]
[(null? (cdr args)) (myeval (car args) env)]
[else [let ([val (myeval (car args) env)])
(if [false? val]
#f
[evand (cdr args) env])]]))
(define (evor args env)
(if [null? args]
#f
[let ([val (myeval (car args) env)])
(if val
val
(evor (cdr args) env))]))
(define (eval-args args env)
(cond
[(null? args) '()]
[else (cons (myeval (car args) env)
(eval-args (cdr args) env))]))
(define (myapply func vals)
(cond
[(eq? (first (func)) 'primitive)
(apply-primitive (second (func)) vals)]
[(eq? (first (func)) 'non-primitive)
(eval-sequence (third (func))
(extend-env
(second (func))
vals
(fourth (func))))]
[else (error func "unexpected case in myapply")]))
(define (apply-primitive name vals)
(cond
[(eq? name 'void) (void)]
[(eq? name 'void?) (void? (first vals))]
[(eq? name 'null?) (null? (first vals))]
[(eq? name 'member) (member (first vals) (second vals))]
[(eq? name 'pair?) (pair? (first vals))]
[(eq? name 'list)
(begin
(define (helper vals)
(if [null? vals]
'()
[cons (car vals) (helper (cdr vals))]))
(helper vals))]
[(eq? name 'cons) (cons (first vals) (second vals))]
[(eq? name 'car) (car (first vals))]
[(eq? name 'cdr) (cdr (first vals))]
[(eq? name 'cddr) (cddr (first vals))]
[(eq? name 'mpair?) (mpair? (first vals))]
[(eq? name 'mcons) (mcons (first vals) (second vals))]
[(eq? name 'mcar) (mcar (first vals))]
[(eq? name 'mcdr) (mcdr (first vals))]
[(eq? name 'set-mcar!) (set-mcar! (first vals) (second vals))]
[(eq? name 'set-mcdr!) (set-mcdr! (first vals) (second vals))]
[(eq? name 'first) (first (first vals))]
[(eq? name 'second) (second (first vals))]
[(eq? name 'third) (third (first vals))]
[(eq? name 'fourth) (fourth (first vals))]
[(eq? name 'boolean?) (boolean? (first vals))]
[(eq? name 'false?) (false? (first vals))]
[(eq? name 'not) (not (first vals))]
[(eq? name 'number?) (number? (first vals))]
[(eq? name '=)
(begin
(define (helper x l)
(cond
[(null? l) #t]
[(= (car l) x) (helper x (cdr l))]
[else #f]))
(if [or (null? vals)
(null? (cdr vals))]
[error "="
"arity mismatch; expects at least 2 arguments."]
[helper (car vals) (cdr vals)]))]
[(eq? name '+) (foldl + 0 vals)]
[(eq? name '-) (- (car vals) (foldl + 0 (cdr vals)))]
[(eq? name '*) (foldl * 1 vals)]
[(eq? name '/) (/ (car vals) (foldl * 1 (cdr vals)))]
[(eq? name 'expt) (expt (first vals) (second vals))]
[(eq? name 'string?) (string? (first vals))]
[(eq? name 'symbol?) (symbol? (first vals))]
[(eq? name 'eq?) (eq? (first vals) (second vals))]
[(eq? name 'equal?) (equal? (first vals) (second vals))]
[(eq? name 'foldl) (foldl (first vals)
(second vals)
(third vals))]
[(eq? name 'error) (error (first vals) (second vals))]))
(eval-sequence lines global-env)
)
(eeval
'(
(define (even? n)
(if [= n 0]
#t
[odd? (- n 1)]))
(define (odd? n)
(if [= n 0]
#f
[even? (- n 1)]))
(define x #f)
(set! x (even? 6))
x
))
#lang racket
(require "interpreter.rkt")
(eeval
'(
(define (eeval lines) ... ) ;; copy paste code from interpreter.rkt
))
#lang R5RS
(#%provide eeval)
(define (eeval lines)
(define first car)
(define second cadr)
(define third caddr)
(define fourth cadddr)
(define (foldl proc init lst)
(cond
((null? lst) init)
(else (foldl proc (proc (car lst) init) (cdr lst)))))
; returns (key . val) if key in frame, #f otherwise
(define (lookup-in-frame key frame)
(cond
((null? frame) #f)
((eq? key (car (car frame))) (car frame))
(else (lookup-in-frame key (cdr frame)))))
; returns (key . val) if key in env, #f otherwise
(define (lookup-in-env key env)
(cond
((null? env) #f)
(else (let ((key-val-pair (lookup-in-frame key (car env))))
(if key-val-pair
key-val-pair
(lookup-in-env key (cdr env)))))))
(define (add-to-env! key value env)
(set-car! env
(cons (cons key value)
(car env))))
(define (update-env! key value env)
(cond
((null? env)
(myerror "set!: assignment disallowed; cannot set variable before its definition \nvariable:" key))
(else (let ((key-val-pair (lookup-in-frame key (car env))))
(if key-val-pair
(set-cdr! key-val-pair value)
(update-env! key value (cdr env)))))))
(define (extend-env keys values env)
(define (new-frame keys values)
(cond
((null? keys) '())
(else (cons (cons (car keys) (car values))
(new-frame (cdr keys) (cdr values))))))
(cons (new-frame keys values) env))
(define global-env (cons '() '()))
(define (myeval expr env)
(cond
((and (not (null? expr)) (not (pair? expr)))
(cond
((boolean? expr) expr)
((number? expr) expr)
((string? expr) expr)
((symbol? expr)
(let ((key-value (lookup-in-env expr env)))
(if key-value
(cdr key-value)
(if (member expr
'(member null? pair?
list cons car cdr cddr
set-car! set-cdr!
cadr caddr cadddr
boolean? not
number? = + - * / expt
string?
symbol? eq? equal?
display))
(lambda () (list 'primitive expr))
(myerror expr "undefined")))))))
((null? expr) (myerror "()" "missing procedure expression."))
((eq? (car expr) 'quote)
(second expr))
((eq? (car expr) 'lambda)
(lambda () (list 'non-primitive
(second expr)
(cddr expr)
env)))
((eq? (car expr) 'define)
(if (not (pair? (second expr)))
(if (lookup-in-frame (second expr) (car env))
(myerror "duplicate definition for identifier in"
(second expr))
(add-to-env! (second expr) (myeval (third expr) env) env))
(myeval (list 'define
(car (second expr))
(cons 'lambda
(cons (cdr (second expr))
(cddr expr))))
env)))
((eq? (car expr) 'set!)
(update-env! (second expr)
(myeval (third expr) env)
env))
((eq? (car expr) 'begin)
(eval-sequence (cdr expr) env))
((eq? (car expr) 'cond)
(evcond (cdr expr) env))
((eq? (car expr) 'if)
(myeval (list 'cond
(list (second expr) (third expr))
(list 'else (fourth expr)))
env))
((eq? (car expr) 'and) (evand (cdr expr) env))
((eq? (car expr) 'or) (evor (cdr expr) env))
((eq? (car expr) 'let)
(eval-sequence (cddr expr)
(extend-env
(map first (second expr))
(map second (second expr))
env)))
(else (myapply (myeval (car expr) env)
(eval-args (cdr expr) env)))
))
(define (eval-sequence lines env)
(cond
((not (null? lines))
(if (null? (cdr lines))
(myeval (car lines) env)
(begin (myeval (car lines) env)
(eval-sequence (cdr lines) env))))))
(define (evcond lines env)
(cond
((not (null? lines))
(cond
((eq? 'else (first (car lines)))
(myeval (second (car lines)) env))
((myeval (first (car lines)) env)
(myeval (second (car lines)) env))
(else (evcond (cdr lines) env))))))
(define (evand args env)
(cond
((null? args) #t)
((null? (cdr args)) (myeval (car args) env))
(else (let ((val (myeval (car args) env)))
(if val
(evand (cdr args) env)
#f)))))
(define (evor args env)
(if (null? args)
#f
(let ((val (myeval (car args) env)))
(if val
val
(evor (cdr args) env)))))
(define (eval-args args env)
(cond
((null? args) '())
(else (cons (myeval (car args) env)
(eval-args (cdr args) env)))))
(define (myapply func vals)
(cond
((eq? (first (func)) 'primitive)
(apply-primitive (second (func)) vals))
((eq? (first (func)) 'non-primitive)
(eval-sequence (third (func))
(extend-env
(second (func))
vals
(fourth (func)))))
(else (myerror func "unexpected case in myapply"))))
(define (apply-primitive name vals)
(define (list-helper vals)
(if (null? vals)
'()
(cons (car vals) (list-helper (cdr vals)))))
(define (=helper x l)
(cond
((null? l) #t)
((= (car l) x) (=helper x (cdr l)))
(else #f)))
(cond
((eq? name 'member) (member (first vals) (second vals)))
((eq? name 'null?) (null? (first vals)))
((eq? name 'pair?) (pair? (first vals)))
((eq? name 'list) (list-helper vals))
((eq? name 'cons) (cons (first vals) (second vals)))
((eq? name 'car) (car (first vals)))
((eq? name 'cdr) (cdr (first vals)))
((eq? name 'cddr) (cddr (first vals)))
((eq? name 'set-car!) (set-car! (first vals) (second vals)))
((eq? name 'set-cdr!) (set-cdr! (first vals) (second vals)))
((eq? name 'cadr) (cadr (first vals)))
((eq? name 'caddr) (caddr (first vals)))
((eq? name 'cadddr) (cadddr (first vals)))
((eq? name 'boolean?) (boolean? (first vals)))
((eq? name 'not) (not (first vals)))
((eq? name 'number?) (number? (first vals)))
((eq? name '=)
(if (or (null? vals)
(null? (cdr vals)))
(myerror "="
"arity mismatch; expects at least 2 arguments.")
(=helper (car vals) (cdr vals))))
((eq? name '+) (foldl + 0 vals))
((eq? name '-) (- (car vals) (foldl + 0 (cdr vals))))
((eq? name '*) (foldl * 1 vals))
((eq? name '/) (/ (car vals) (foldl * 1 (cdr vals))))
((eq? name 'expt) (expt (first vals) (second vals)))
((eq? name 'string?) (string? (first vals)))
((eq? name 'symbol?) (symbol? (first vals)))
((eq? name 'eq?) (eq? (first vals) (second vals)))
((eq? name 'equal?) (equal? (first vals) (second vals)))
((eq? name 'display) (display (first vals)))
))
(define (myerror expr1 expr2)
(begin
(display expr1)
(display " ")
(display expr2)
(newline)))
(eval-sequence lines global-env)
)
(eeval
'(
(define (even? n)
(if (= n 0)
#t
(odd? (- n 1))))
(define (odd? n)
(if (= n 0)
#f
(even? (- n 1))))
(define x #f)
(set! x (even? 6))
(display x)
))
#lang R5RS
(#%require "interpreter-r5rs.rkt")
(eeval
'(
(define (eeval lines) ... ) ;; copy paste code from interpreter.rkt
))
#lang racket
(provide eeval)
(define (eeval lines)
;; The global environment is a mutable list of frames,
;; where each frame is a mutable list of
;; mutable variable-value pairs.
;; When a function is called, it creates a new frame
;; which is a mutable list of parameter-argument pairs.
;; Then it mcons the new frame to the enviroment the
;; function was defined in.
(define global-env (mcons '() '()))
; returns (mcons key val) if key in frame, #f otherwise
(define (lookup-in-frame key frame)
(cond
[(null? frame) #f]
[(eq? key (mcar (mcar frame))) (mcar frame)]
[else (lookup-in-frame key (mcdr frame))]))
; returns (mcons key val) if key in env, #f otherwise
(define (lookup-in-env key env)
(cond
[(null? env) #f]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
key-val-pair
(lookup-in-env key (mcdr env))))]))
(define (add-to-env! key value env)
(set-mcar! env
(mcons (mcons key value)
(mcar env))))
(define (update-env! key value env)
(cond
[(null? env)
(error "set!: assignment disallowed; cannot set variable before its definition \nvariable:" key)]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
(set-mcdr! key-val-pair value)
(update-env! key value (mcdr env))))]))
(define (extend-env keys values env)
(define (new-frame keys values)
(cond
((null? keys) '())
(else (mcons (mcons (car keys) (car values))
(new-frame (cdr keys) (cdr values))))))
(mcons (new-frame keys values) env))
(define (myeval expr env)
(cond
[(and (not (null? expr)) (not (pair? expr)))
(cond
[(boolean? expr) expr]
[(number? expr) expr]
[(string? expr) expr]
[(symbol? expr)
(let ([key-value (lookup-in-env expr env)])
(if key-value
[mcdr key-value]
[if [member expr
'(void void? null? member
pair? list cons car cdr cddr
mpair? mcons mcar mcdr
set-mcar! set-mcdr!
first second third fourth
boolean? false? not
number? = + - * / expt
string?
symbol? eq? equal?
display error)]
[lambda () (list 'primitive expr)]
[error expr "undefined"]]))])]
[(null? expr) (error "()" "missing procedure expression.")]
[(eq? (car expr) 'quote)
(second expr)]
[(eq? (car expr) 'lambda)
(lambda () (list 'non-primitive
(second expr)
(cddr expr)
env))]
[(eq? (car expr) 'define)
(if [not (pair? (second expr))]
[if [false? (lookup-in-frame (second expr) (mcar env))]
[add-to-env! (second expr) (myeval (third expr) env) env]
[error "duplicate definition for identifier in"
(second expr)]]
[myeval (list 'define
(car (second expr))
(cons 'lambda
(cons (cdr (second expr))
(cddr expr))))
env])]
[(eq? (car expr) 'set!)
(update-env! (second expr)
(myeval (third expr) env)
env)]
[(eq? (car expr) 'begin)
(eval-sequence (cdr expr) env)]
[(eq? (car expr) 'cond)
(evcond (cdr expr) env)]
[(eq? (car expr) 'if)
(myeval (list 'cond
(list (second expr) (third expr))
(list 'else (fourth expr)))
env)]
[(eq? (car expr) 'and) (evand (cdr expr) env)]
[(eq? (car expr) 'or) (evor (cdr expr) env)]
[(eq? (car expr) 'let)
(eval-sequence (cddr expr)
(extend-env
(map first (second expr))
(eval-args (map second (second expr)) env)
env))]
[else (myapply (myeval (car expr) env)
(eval-args (cdr expr) env))]
))
(define (eval-sequence lines env)
(if [null? lines]
[void]
(if [null? (cdr lines)]
[myeval (car lines) env]
[begin (myeval (car lines) env)
(eval-sequence (cdr lines) env)])))
(define (evcond lines env)
(cond
[(null? lines) (void)]
[(eq? 'else (first (car lines)))
(myeval (second (car lines)) env)]
[(myeval (first (car lines)) env)
(myeval (second (car lines)) env)]
[else (evcond (cdr lines) env)]))
(define (evand args env)
(cond
[(null? args) #t]
[(null? (cdr args)) (myeval (car args) env)]
[else [let ([val (myeval (car args) env)])
(if [false? val]
#f
[evand (cdr args) env])]]))
(define (evor args env)
(if [null? args]
#f
[let ([val (myeval (car args) env)])
(if val
val
(evor (cdr args) env))]))
(define (eval-args args env)
(cond
[(null? args) '()]
[else (cons (myeval (car args) env)
(eval-args (cdr args) env))]))
(define (myapply func vals)
(cond
[(eq? (first (func)) 'primitive)
(apply-primitive (second (func)) vals)]
[(eq? (first (func)) 'non-primitive)
(eval-sequence (third (func))
(extend-env
(second (func))
vals
(fourth (func))))]
[else (error func "unexpected case in myapply")]))
(define (apply-primitive name vals)
(cond
[(eq? name 'void) (void)]
[(eq? name 'void?) (void? (first vals))]
[(eq? name 'null?) (null? (first vals))]
[(eq? name 'member) (member (first vals) (second vals))]
[(eq? name 'pair?) (pair? (first vals))]
[(eq? name 'list)
(begin
(define (helper vals)
(if [null? vals]
'()
[cons (car vals) (helper (cdr vals))]))
(helper vals))]
[(eq? name 'cons) (cons (first vals) (second vals))]
[(eq? name 'car) (car (first vals))]
[(eq? name 'cdr) (cdr (first vals))]
[(eq? name 'cddr) (cddr (first vals))]
[(eq? name 'mpair?) (mpair? (first vals))]
[(eq? name 'mcons) (mcons (first vals) (second vals))]
[(eq? name 'mcar) (mcar (first vals))]
[(eq? name 'mcdr) (mcdr (first vals))]
[(eq? name 'set-mcar!) (set-mcar! (first vals) (second vals))]
[(eq? name 'set-mcdr!) (set-mcdr! (first vals) (second vals))]
[(eq? name 'first) (first (first vals))]
[(eq? name 'second) (second (first vals))]
[(eq? name 'third) (third (first vals))]
[(eq? name 'fourth) (fourth (first vals))]
[(eq? name 'boolean?) (boolean? (first vals))]
[(eq? name 'false?) (false? (first vals))]
[(eq? name 'not) (not (first vals))]
[(eq? name 'number?) (number? (first vals))]
[(eq? name '=)
(begin
(define (helper x l)
(cond
[(null? l) #t]
[(= (car l) x) (helper x (cdr l))]
[else #f]))
(if [or (null? vals)
(null? (cdr vals))]
[error "="
"arity mismatch; expects at least 2 arguments."]
[helper (car vals) (cdr vals)]))]
[(eq? name '+) (foldl + 0 vals)]
[(eq? name '-) (- (car vals) (foldl + 0 (cdr vals)))]
[(eq? name '*) (foldl * 1 vals)]
[(eq? name '/) (/ (car vals) (foldl * 1 (cdr vals)))]
[(eq? name 'expt) (expt (first vals) (second vals))]
[(eq? name 'string?) (string? (first vals))]
[(eq? name 'symbol?) (symbol? (first vals))]
[(eq? name 'eq?) (eq? (first vals) (second vals))]
[(eq? name 'equal?) (equal? (first vals) (second vals))]
; [(eq? name 'foldl) (foldl (first vals)
; (second vals)
; (third vals))]
((eq? name 'display) (display (first vals)))
[(eq? name 'error) (error (first vals) (second vals))]))
(define (foldl proc init lst)
(cond
((null? lst) init)
(else (foldl proc (proc (car lst) init) (cdr lst)))))
(define (eval-print-sequence lines)
(if [null? lines]
[void]
[let ([result (myeval (car lines) global-env)])
(if [void? result]
[eval-print-sequence (cdr lines)]
[begin (display result)
(display "\n")
(eval-print-sequence (cdr lines))])]))
(eval-print-sequence lines)
)
(eeval
'(
(define (even? n)
(if [= n 0]
#t
[odd? (- n 1)]))
(define (odd? n)
(if [= n 0]
#f
[even? (- n 1)]))
(define x #f)
(set! x (even? 6))
x
))
解释器-r5rs-test.rkt#lang racket
(provide eeval)
(define (eeval lines)
; returns (key . val) if key in frame, #f otherwise
(define (lookup-in-frame key frame)
(cond
[(null? frame) #f]
[(eq? key (mcar (mcar frame))) (mcar frame)]
[else (lookup-in-frame key (mcdr frame))]))
; returns (key . val) if key in env, #f otherwise
(define (lookup-in-env key env)
(cond
[(null? env) #f]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
key-val-pair
(lookup-in-env key (mcdr env))))]))
(define (add-to-env! key value env)
(set-mcar! env
(mcons (mcons key value)
(mcar env))))
(define (update-env! key value env)
(cond
[(null? env)
(error "set!: assignment disallowed; cannot set variable before its definition \nvariable:" key)]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
(set-mcdr! key-val-pair value)
(update-env! key value (mcdr env))))]))
(define (extend-env keys values env)
(define (new-frame keys values)
(cond
((null? keys) '())
(else (mcons (mcons (car keys) (car values))
(new-frame (cdr keys) (cdr values))))))
(mcons (new-frame keys values) env))
(define global-env (mcons '() '()))
(define (myeval expr env)
(cond
[(and (not (null? expr)) (not (pair? expr)))
(cond
[(boolean? expr) expr]
[(number? expr) expr]
[(string? expr) expr]
[(symbol? expr)
(let ([key-value (lookup-in-env expr env)])
(if key-value
[mcdr key-value]
[if [member expr
'(void void? null? member
pair? list cons car cdr cddr
mpair? mcons mcar mcdr
set-mcar! set-mcdr!
first second third fourth
boolean? false? not
number? = + - * / expt
string?
symbol? eq? equal?
foldl error)]
[lambda () (list 'primitive expr)]
[error expr "undefined"]]))])]
[(null? expr) (error "()" "missing procedure expression.")]
[(eq? (car expr) 'quote)
(second expr)]
[(eq? (car expr) 'lambda)
(lambda () (list 'non-primitive
(second expr)
(cddr expr)
env))]
[(eq? (car expr) 'define)
(if [not (pair? (second expr))]
[if [false? (lookup-in-frame (second expr) (mcar env))]
[add-to-env! (second expr) (myeval (third expr) env) env]
[error "duplicate definition for identifier in"
(second expr)]]
[myeval (list 'define
(car (second expr))
(cons 'lambda
(cons (cdr (second expr))
(cddr expr))))
env])]
[(eq? (car expr) 'set!)
(update-env! (second expr)
(myeval (third expr) env)
env)]
[(eq? (car expr) 'begin)
(eval-sequence (cdr expr) env)]
[(eq? (car expr) 'cond)
(evcond (cdr expr) env)]
[(eq? (car expr) 'if)
(myeval (list 'cond
(list (second expr) (third expr))
(list 'else (fourth expr)))
env)]
[(eq? (car expr) 'and) (evand (cdr expr) env)]
[(eq? (car expr) 'or) (evor (cdr expr) env)]
[(eq? (car expr) 'let)
(eval-sequence (cddr expr)
(extend-env
(map first (second expr))
(map second (second expr))
env))]
[else (myapply (myeval (car expr) env)
(eval-args (cdr expr) env))]
))
(define (eval-sequence lines env)
(if [null? lines]
[void]
(if [null? (cdr lines)]
[myeval (car lines) env]
[begin (myeval (car lines) env)
(eval-sequence (cdr lines) env)])))
(define (evcond lines env)
(cond
[(null? lines) (void)]
[(eq? 'else (first (car lines)))
(myeval (second (car lines)) env)]
[(myeval (first (car lines)) env)
(myeval (second (car lines)) env)]
[else (evcond (cdr lines) env)]))
(define (evand args env)
(cond
[(null? args) #t]
[(null? (cdr args)) (myeval (car args) env)]
[else [let ([val (myeval (car args) env)])
(if [false? val]
#f
[evand (cdr args) env])]]))
(define (evor args env)
(if [null? args]
#f
[let ([val (myeval (car args) env)])
(if val
val
(evor (cdr args) env))]))
(define (eval-args args env)
(cond
[(null? args) '()]
[else (cons (myeval (car args) env)
(eval-args (cdr args) env))]))
(define (myapply func vals)
(cond
[(eq? (first (func)) 'primitive)
(apply-primitive (second (func)) vals)]
[(eq? (first (func)) 'non-primitive)
(eval-sequence (third (func))
(extend-env
(second (func))
vals
(fourth (func))))]
[else (error func "unexpected case in myapply")]))
(define (apply-primitive name vals)
(cond
[(eq? name 'void) (void)]
[(eq? name 'void?) (void? (first vals))]
[(eq? name 'null?) (null? (first vals))]
[(eq? name 'member) (member (first vals) (second vals))]
[(eq? name 'pair?) (pair? (first vals))]
[(eq? name 'list)
(begin
(define (helper vals)
(if [null? vals]
'()
[cons (car vals) (helper (cdr vals))]))
(helper vals))]
[(eq? name 'cons) (cons (first vals) (second vals))]
[(eq? name 'car) (car (first vals))]
[(eq? name 'cdr) (cdr (first vals))]
[(eq? name 'cddr) (cddr (first vals))]
[(eq? name 'mpair?) (mpair? (first vals))]
[(eq? name 'mcons) (mcons (first vals) (second vals))]
[(eq? name 'mcar) (mcar (first vals))]
[(eq? name 'mcdr) (mcdr (first vals))]
[(eq? name 'set-mcar!) (set-mcar! (first vals) (second vals))]
[(eq? name 'set-mcdr!) (set-mcdr! (first vals) (second vals))]
[(eq? name 'first) (first (first vals))]
[(eq? name 'second) (second (first vals))]
[(eq? name 'third) (third (first vals))]
[(eq? name 'fourth) (fourth (first vals))]
[(eq? name 'boolean?) (boolean? (first vals))]
[(eq? name 'false?) (false? (first vals))]
[(eq? name 'not) (not (first vals))]
[(eq? name 'number?) (number? (first vals))]
[(eq? name '=)
(begin
(define (helper x l)
(cond
[(null? l) #t]
[(= (car l) x) (helper x (cdr l))]
[else #f]))
(if [or (null? vals)
(null? (cdr vals))]
[error "="
"arity mismatch; expects at least 2 arguments."]
[helper (car vals) (cdr vals)]))]
[(eq? name '+) (foldl + 0 vals)]
[(eq? name '-) (- (car vals) (foldl + 0 (cdr vals)))]
[(eq? name '*) (foldl * 1 vals)]
[(eq? name '/) (/ (car vals) (foldl * 1 (cdr vals)))]
[(eq? name 'expt) (expt (first vals) (second vals))]
[(eq? name 'string?) (string? (first vals))]
[(eq? name 'symbol?) (symbol? (first vals))]
[(eq? name 'eq?) (eq? (first vals) (second vals))]
[(eq? name 'equal?) (equal? (first vals) (second vals))]
[(eq? name 'foldl) (foldl (first vals)
(second vals)
(third vals))]
[(eq? name 'error) (error (first vals) (second vals))]))
(eval-sequence lines global-env)
)
(eeval
'(
(define (even? n)
(if [= n 0]
#t
[odd? (- n 1)]))
(define (odd? n)
(if [= n 0]
#f
[even? (- n 1)]))
(define x #f)
(set! x (even? 6))
x
))
#lang racket
(require "interpreter.rkt")
(eeval
'(
(define (eeval lines) ... ) ;; copy paste code from interpreter.rkt
))
#lang R5RS
(#%provide eeval)
(define (eeval lines)
(define first car)
(define second cadr)
(define third caddr)
(define fourth cadddr)
(define (foldl proc init lst)
(cond
((null? lst) init)
(else (foldl proc (proc (car lst) init) (cdr lst)))))
; returns (key . val) if key in frame, #f otherwise
(define (lookup-in-frame key frame)
(cond
((null? frame) #f)
((eq? key (car (car frame))) (car frame))
(else (lookup-in-frame key (cdr frame)))))
; returns (key . val) if key in env, #f otherwise
(define (lookup-in-env key env)
(cond
((null? env) #f)
(else (let ((key-val-pair (lookup-in-frame key (car env))))
(if key-val-pair
key-val-pair
(lookup-in-env key (cdr env)))))))
(define (add-to-env! key value env)
(set-car! env
(cons (cons key value)
(car env))))
(define (update-env! key value env)
(cond
((null? env)
(myerror "set!: assignment disallowed; cannot set variable before its definition \nvariable:" key))
(else (let ((key-val-pair (lookup-in-frame key (car env))))
(if key-val-pair
(set-cdr! key-val-pair value)
(update-env! key value (cdr env)))))))
(define (extend-env keys values env)
(define (new-frame keys values)
(cond
((null? keys) '())
(else (cons (cons (car keys) (car values))
(new-frame (cdr keys) (cdr values))))))
(cons (new-frame keys values) env))
(define global-env (cons '() '()))
(define (myeval expr env)
(cond
((and (not (null? expr)) (not (pair? expr)))
(cond
((boolean? expr) expr)
((number? expr) expr)
((string? expr) expr)
((symbol? expr)
(let ((key-value (lookup-in-env expr env)))
(if key-value
(cdr key-value)
(if (member expr
'(member null? pair?
list cons car cdr cddr
set-car! set-cdr!
cadr caddr cadddr
boolean? not
number? = + - * / expt
string?
symbol? eq? equal?
display))
(lambda () (list 'primitive expr))
(myerror expr "undefined")))))))
((null? expr) (myerror "()" "missing procedure expression."))
((eq? (car expr) 'quote)
(second expr))
((eq? (car expr) 'lambda)
(lambda () (list 'non-primitive
(second expr)
(cddr expr)
env)))
((eq? (car expr) 'define)
(if (not (pair? (second expr)))
(if (lookup-in-frame (second expr) (car env))
(myerror "duplicate definition for identifier in"
(second expr))
(add-to-env! (second expr) (myeval (third expr) env) env))
(myeval (list 'define
(car (second expr))
(cons 'lambda
(cons (cdr (second expr))
(cddr expr))))
env)))
((eq? (car expr) 'set!)
(update-env! (second expr)
(myeval (third expr) env)
env))
((eq? (car expr) 'begin)
(eval-sequence (cdr expr) env))
((eq? (car expr) 'cond)
(evcond (cdr expr) env))
((eq? (car expr) 'if)
(myeval (list 'cond
(list (second expr) (third expr))
(list 'else (fourth expr)))
env))
((eq? (car expr) 'and) (evand (cdr expr) env))
((eq? (car expr) 'or) (evor (cdr expr) env))
((eq? (car expr) 'let)
(eval-sequence (cddr expr)
(extend-env
(map first (second expr))
(map second (second expr))
env)))
(else (myapply (myeval (car expr) env)
(eval-args (cdr expr) env)))
))
(define (eval-sequence lines env)
(cond
((not (null? lines))
(if (null? (cdr lines))
(myeval (car lines) env)
(begin (myeval (car lines) env)
(eval-sequence (cdr lines) env))))))
(define (evcond lines env)
(cond
((not (null? lines))
(cond
((eq? 'else (first (car lines)))
(myeval (second (car lines)) env))
((myeval (first (car lines)) env)
(myeval (second (car lines)) env))
(else (evcond (cdr lines) env))))))
(define (evand args env)
(cond
((null? args) #t)
((null? (cdr args)) (myeval (car args) env))
(else (let ((val (myeval (car args) env)))
(if val
(evand (cdr args) env)
#f)))))
(define (evor args env)
(if (null? args)
#f
(let ((val (myeval (car args) env)))
(if val
val
(evor (cdr args) env)))))
(define (eval-args args env)
(cond
((null? args) '())
(else (cons (myeval (car args) env)
(eval-args (cdr args) env)))))
(define (myapply func vals)
(cond
((eq? (first (func)) 'primitive)
(apply-primitive (second (func)) vals))
((eq? (first (func)) 'non-primitive)
(eval-sequence (third (func))
(extend-env
(second (func))
vals
(fourth (func)))))
(else (myerror func "unexpected case in myapply"))))
(define (apply-primitive name vals)
(define (list-helper vals)
(if (null? vals)
'()
(cons (car vals) (list-helper (cdr vals)))))
(define (=helper x l)
(cond
((null? l) #t)
((= (car l) x) (=helper x (cdr l)))
(else #f)))
(cond
((eq? name 'member) (member (first vals) (second vals)))
((eq? name 'null?) (null? (first vals)))
((eq? name 'pair?) (pair? (first vals)))
((eq? name 'list) (list-helper vals))
((eq? name 'cons) (cons (first vals) (second vals)))
((eq? name 'car) (car (first vals)))
((eq? name 'cdr) (cdr (first vals)))
((eq? name 'cddr) (cddr (first vals)))
((eq? name 'set-car!) (set-car! (first vals) (second vals)))
((eq? name 'set-cdr!) (set-cdr! (first vals) (second vals)))
((eq? name 'cadr) (cadr (first vals)))
((eq? name 'caddr) (caddr (first vals)))
((eq? name 'cadddr) (cadddr (first vals)))
((eq? name 'boolean?) (boolean? (first vals)))
((eq? name 'not) (not (first vals)))
((eq? name 'number?) (number? (first vals)))
((eq? name '=)
(if (or (null? vals)
(null? (cdr vals)))
(myerror "="
"arity mismatch; expects at least 2 arguments.")
(=helper (car vals) (cdr vals))))
((eq? name '+) (foldl + 0 vals))
((eq? name '-) (- (car vals) (foldl + 0 (cdr vals))))
((eq? name '*) (foldl * 1 vals))
((eq? name '/) (/ (car vals) (foldl * 1 (cdr vals))))
((eq? name 'expt) (expt (first vals) (second vals)))
((eq? name 'string?) (string? (first vals)))
((eq? name 'symbol?) (symbol? (first vals)))
((eq? name 'eq?) (eq? (first vals) (second vals)))
((eq? name 'equal?) (equal? (first vals) (second vals)))
((eq? name 'display) (display (first vals)))
))
(define (myerror expr1 expr2)
(begin
(display expr1)
(display " ")
(display expr2)
(newline)))
(eval-sequence lines global-env)
)
(eeval
'(
(define (even? n)
(if (= n 0)
#t
(odd? (- n 1))))
(define (odd? n)
(if (= n 0)
#f
(even? (- n 1))))
(define x #f)
(set! x (even? 6))
(display x)
))
#lang R5RS
(#%require "interpreter-r5rs.rkt")
(eeval
'(
(define (eeval lines) ... ) ;; copy paste code from interpreter.rkt
))
#lang racket
(provide eeval)
(define (eeval lines)
;; The global environment is a mutable list of frames,
;; where each frame is a mutable list of
;; mutable variable-value pairs.
;; When a function is called, it creates a new frame
;; which is a mutable list of parameter-argument pairs.
;; Then it mcons the new frame to the enviroment the
;; function was defined in.
(define global-env (mcons '() '()))
; returns (mcons key val) if key in frame, #f otherwise
(define (lookup-in-frame key frame)
(cond
[(null? frame) #f]
[(eq? key (mcar (mcar frame))) (mcar frame)]
[else (lookup-in-frame key (mcdr frame))]))
; returns (mcons key val) if key in env, #f otherwise
(define (lookup-in-env key env)
(cond
[(null? env) #f]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
key-val-pair
(lookup-in-env key (mcdr env))))]))
(define (add-to-env! key value env)
(set-mcar! env
(mcons (mcons key value)
(mcar env))))
(define (update-env! key value env)
(cond
[(null? env)
(error "set!: assignment disallowed; cannot set variable before its definition \nvariable:" key)]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
(set-mcdr! key-val-pair value)
(update-env! key value (mcdr env))))]))
(define (extend-env keys values env)
(define (new-frame keys values)
(cond
((null? keys) '())
(else (mcons (mcons (car keys) (car values))
(new-frame (cdr keys) (cdr values))))))
(mcons (new-frame keys values) env))
(define (myeval expr env)
(cond
[(and (not (null? expr)) (not (pair? expr)))
(cond
[(boolean? expr) expr]
[(number? expr) expr]
[(string? expr) expr]
[(symbol? expr)
(let ([key-value (lookup-in-env expr env)])
(if key-value
[mcdr key-value]
[if [member expr
'(void void? null? member
pair? list cons car cdr cddr
mpair? mcons mcar mcdr
set-mcar! set-mcdr!
first second third fourth
boolean? false? not
number? = + - * / expt
string?
symbol? eq? equal?
display error)]
[lambda () (list 'primitive expr)]
[error expr "undefined"]]))])]
[(null? expr) (error "()" "missing procedure expression.")]
[(eq? (car expr) 'quote)
(second expr)]
[(eq? (car expr) 'lambda)
(lambda () (list 'non-primitive
(second expr)
(cddr expr)
env))]
[(eq? (car expr) 'define)
(if [not (pair? (second expr))]
[if [false? (lookup-in-frame (second expr) (mcar env))]
[add-to-env! (second expr) (myeval (third expr) env) env]
[error "duplicate definition for identifier in"
(second expr)]]
[myeval (list 'define
(car (second expr))
(cons 'lambda
(cons (cdr (second expr))
(cddr expr))))
env])]
[(eq? (car expr) 'set!)
(update-env! (second expr)
(myeval (third expr) env)
env)]
[(eq? (car expr) 'begin)
(eval-sequence (cdr expr) env)]
[(eq? (car expr) 'cond)
(evcond (cdr expr) env)]
[(eq? (car expr) 'if)
(myeval (list 'cond
(list (second expr) (third expr))
(list 'else (fourth expr)))
env)]
[(eq? (car expr) 'and) (evand (cdr expr) env)]
[(eq? (car expr) 'or) (evor (cdr expr) env)]
[(eq? (car expr) 'let)
(eval-sequence (cddr expr)
(extend-env
(map first (second expr))
(eval-args (map second (second expr)) env)
env))]
[else (myapply (myeval (car expr) env)
(eval-args (cdr expr) env))]
))
(define (eval-sequence lines env)
(if [null? lines]
[void]
(if [null? (cdr lines)]
[myeval (car lines) env]
[begin (myeval (car lines) env)
(eval-sequence (cdr lines) env)])))
(define (evcond lines env)
(cond
[(null? lines) (void)]
[(eq? 'else (first (car lines)))
(myeval (second (car lines)) env)]
[(myeval (first (car lines)) env)
(myeval (second (car lines)) env)]
[else (evcond (cdr lines) env)]))
(define (evand args env)
(cond
[(null? args) #t]
[(null? (cdr args)) (myeval (car args) env)]
[else [let ([val (myeval (car args) env)])
(if [false? val]
#f
[evand (cdr args) env])]]))
(define (evor args env)
(if [null? args]
#f
[let ([val (myeval (car args) env)])
(if val
val
(evor (cdr args) env))]))
(define (eval-args args env)
(cond
[(null? args) '()]
[else (cons (myeval (car args) env)
(eval-args (cdr args) env))]))
(define (myapply func vals)
(cond
[(eq? (first (func)) 'primitive)
(apply-primitive (second (func)) vals)]
[(eq? (first (func)) 'non-primitive)
(eval-sequence (third (func))
(extend-env
(second (func))
vals
(fourth (func))))]
[else (error func "unexpected case in myapply")]))
(define (apply-primitive name vals)
(cond
[(eq? name 'void) (void)]
[(eq? name 'void?) (void? (first vals))]
[(eq? name 'null?) (null? (first vals))]
[(eq? name 'member) (member (first vals) (second vals))]
[(eq? name 'pair?) (pair? (first vals))]
[(eq? name 'list)
(begin
(define (helper vals)
(if [null? vals]
'()
[cons (car vals) (helper (cdr vals))]))
(helper vals))]
[(eq? name 'cons) (cons (first vals) (second vals))]
[(eq? name 'car) (car (first vals))]
[(eq? name 'cdr) (cdr (first vals))]
[(eq? name 'cddr) (cddr (first vals))]
[(eq? name 'mpair?) (mpair? (first vals))]
[(eq? name 'mcons) (mcons (first vals) (second vals))]
[(eq? name 'mcar) (mcar (first vals))]
[(eq? name 'mcdr) (mcdr (first vals))]
[(eq? name 'set-mcar!) (set-mcar! (first vals) (second vals))]
[(eq? name 'set-mcdr!) (set-mcdr! (first vals) (second vals))]
[(eq? name 'first) (first (first vals))]
[(eq? name 'second) (second (first vals))]
[(eq? name 'third) (third (first vals))]
[(eq? name 'fourth) (fourth (first vals))]
[(eq? name 'boolean?) (boolean? (first vals))]
[(eq? name 'false?) (false? (first vals))]
[(eq? name 'not) (not (first vals))]
[(eq? name 'number?) (number? (first vals))]
[(eq? name '=)
(begin
(define (helper x l)
(cond
[(null? l) #t]
[(= (car l) x) (helper x (cdr l))]
[else #f]))
(if [or (null? vals)
(null? (cdr vals))]
[error "="
"arity mismatch; expects at least 2 arguments."]
[helper (car vals) (cdr vals)]))]
[(eq? name '+) (foldl + 0 vals)]
[(eq? name '-) (- (car vals) (foldl + 0 (cdr vals)))]
[(eq? name '*) (foldl * 1 vals)]
[(eq? name '/) (/ (car vals) (foldl * 1 (cdr vals)))]
[(eq? name 'expt) (expt (first vals) (second vals))]
[(eq? name 'string?) (string? (first vals))]
[(eq? name 'symbol?) (symbol? (first vals))]
[(eq? name 'eq?) (eq? (first vals) (second vals))]
[(eq? name 'equal?) (equal? (first vals) (second vals))]
; [(eq? name 'foldl) (foldl (first vals)
; (second vals)
; (third vals))]
((eq? name 'display) (display (first vals)))
[(eq? name 'error) (error (first vals) (second vals))]))
(define (foldl proc init lst)
(cond
((null? lst) init)
(else (foldl proc (proc (car lst) init) (cdr lst)))))
(define (eval-print-sequence lines)
(if [null? lines]
[void]
[let ([result (myeval (car lines) global-env)])
(if [void? result]
[eval-print-sequence (cdr lines)]
[begin (display result)
(display "\n")
(eval-print-sequence (cdr lines))])]))
(eval-print-sequence lines)
)
(eeval
'(
(define (even? n)
(if [= n 0]
#t
[odd? (- n 1)]))
(define (odd? n)
(if [= n 0]
#f
[even? (- n 1)]))
(define x #f)
(set! x (even? 6))
x
))
; application: not a procedure;
; expected a procedure that can be applied to arguments
; given: (mcons 'expr (mcons 'env))
; arguments...: [none]
(cons 'x 'y)
(mcons 'x 'y)
(require compatibility/mlist)
(mlist 'a 'b 'c)
'(a b c)
(mcons 'x 'y)
(require compatibility/mlist)
(mlist 'a 'b 'c)
我建议您将环境、框架和绑定表示为结构
#lang racket
; From SICP:
; An environment is a sequence of frames.
(struct environment (frames) #:mutable #:transparent)
; Each frame is a table (possibly empty) of bindings,
; which associate variable names with their corresponding values.
; (A single frame may contain at most one binding for any variable.)
; Each frame also has a pointer to its enclosing environment, unless,
; for the purposes of discussion, the frame is considered to be global.
(struct frame (bindings parent) #:mutable #:transparent)
; The value of a variable with respect to an environment is the value
; given by the binding of the variable in the first frame in the environment
; that contains a binding for that variable.
(struct binding (key value) #:mutable #:transparent)
; If no frame in the sequence specifies a binding for the variable,
; then the variable is said to be unbound in the environment.
(define (lookup-in-env key env)
(match env
[(environment frames)
(lookup-in-frames key frames)]))
(define (lookup-in-frames key frames)
(match frames
['() #f] ; unbound
[(cons f fs) (or (lookup-in-frame key f)
(lookup-in-frames key fs))]))
(define (lookup-in-frame key f)
(match f
[(frame bindings parent)
(lookup-in-bindings key bindings)]))
(define (lookup-in-bindings key bindings)
(match bindings
['() #f] ; unbound
[(cons b bs) (if (eq? key (binding-key b))
b ; binding with key-value paring
(lookup-in-bindings key bs))]))
(define (add-frame-to-env! f env)
(match env
[(environment frames)
(set-environment-frames! env (cons f frames))]))
(define (update-env! key value env)
(let ([b (lookup-in-env key env)])
(if b
(set-binding-value! b value)
(error 'update-env! (~a "no binding for " key)))))
(define (extend-env keys values env)
(match env
[(environment (cons top-frame frames))
(define bs (map binding keys values))
(define new-f (frame bs top-frame))
(set-environment-frames! env (cons new-f (cons top-frame frames)))]))
(define global-env (environment (list (frame '() #f))))
(lookup-in-env '+ global-env) ; #f since plus is unbound
(extend-env '(+ - * /) (list + - * /) global-env)
(lookup-in-env '+ global-env)
感谢Racket用户邮件列表上的Matthias Felleisen:，我发现了这个问题。它与cons、mcon或引号无关 问题是解释器.rkt中的错误。在解释器.rkt中，根据myeval的定义，对于let表达式，它应该是：
[(eq? (car expr) 'let)
(eval-sequence (cddr expr)
(extend-env
(map first (second expr))
(eval-args (map second (second expr)) env)
env))]
(define (foldl proc init lst)
(cond
((null? lst) init)
(else (foldl proc (proc (car lst) init) (cdr lst)))))
解释器.rkt#lang racket
(provide eeval)
(define (eeval lines)
; returns (key . val) if key in frame, #f otherwise
(define (lookup-in-frame key frame)
(cond
[(null? frame) #f]
[(eq? key (mcar (mcar frame))) (mcar frame)]
[else (lookup-in-frame key (mcdr frame))]))
; returns (key . val) if key in env, #f otherwise
(define (lookup-in-env key env)
(cond
[(null? env) #f]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
key-val-pair
(lookup-in-env key (mcdr env))))]))
(define (add-to-env! key value env)
(set-mcar! env
(mcons (mcons key value)
(mcar env))))
(define (update-env! key value env)
(cond
[(null? env)
(error "set!: assignment disallowed; cannot set variable before its definition \nvariable:" key)]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
(set-mcdr! key-val-pair value)
(update-env! key value (mcdr env))))]))
(define (extend-env keys values env)
(define (new-frame keys values)
(cond
((null? keys) '())
(else (mcons (mcons (car keys) (car values))
(new-frame (cdr keys) (cdr values))))))
(mcons (new-frame keys values) env))
(define global-env (mcons '() '()))
(define (myeval expr env)
(cond
[(and (not (null? expr)) (not (pair? expr)))
(cond
[(boolean? expr) expr]
[(number? expr) expr]
[(string? expr) expr]
[(symbol? expr)
(let ([key-value (lookup-in-env expr env)])
(if key-value
[mcdr key-value]
[if [member expr
'(void void? null? member
pair? list cons car cdr cddr
mpair? mcons mcar mcdr
set-mcar! set-mcdr!
first second third fourth
boolean? false? not
number? = + - * / expt
string?
symbol? eq? equal?
foldl error)]
[lambda () (list 'primitive expr)]
[error expr "undefined"]]))])]
[(null? expr) (error "()" "missing procedure expression.")]
[(eq? (car expr) 'quote)
(second expr)]
[(eq? (car expr) 'lambda)
(lambda () (list 'non-primitive
(second expr)
(cddr expr)
env))]
[(eq? (car expr) 'define)
(if [not (pair? (second expr))]
[if [false? (lookup-in-frame (second expr) (mcar env))]
[add-to-env! (second expr) (myeval (third expr) env) env]
[error "duplicate definition for identifier in"
(second expr)]]
[myeval (list 'define
(car (second expr))
(cons 'lambda
(cons (cdr (second expr))
(cddr expr))))
env])]
[(eq? (car expr) 'set!)
(update-env! (second expr)
(myeval (third expr) env)
env)]
[(eq? (car expr) 'begin)
(eval-sequence (cdr expr) env)]
[(eq? (car expr) 'cond)
(evcond (cdr expr) env)]
[(eq? (car expr) 'if)
(myeval (list 'cond
(list (second expr) (third expr))
(list 'else (fourth expr)))
env)]
[(eq? (car expr) 'and) (evand (cdr expr) env)]
[(eq? (car expr) 'or) (evor (cdr expr) env)]
[(eq? (car expr) 'let)
(eval-sequence (cddr expr)
(extend-env
(map first (second expr))
(map second (second expr))
env))]
[else (myapply (myeval (car expr) env)
(eval-args (cdr expr) env))]
))
(define (eval-sequence lines env)
(if [null? lines]
[void]
(if [null? (cdr lines)]
[myeval (car lines) env]
[begin (myeval (car lines) env)
(eval-sequence (cdr lines) env)])))
(define (evcond lines env)
(cond
[(null? lines) (void)]
[(eq? 'else (first (car lines)))
(myeval (second (car lines)) env)]
[(myeval (first (car lines)) env)
(myeval (second (car lines)) env)]
[else (evcond (cdr lines) env)]))
(define (evand args env)
(cond
[(null? args) #t]
[(null? (cdr args)) (myeval (car args) env)]
[else [let ([val (myeval (car args) env)])
(if [false? val]
#f
[evand (cdr args) env])]]))
(define (evor args env)
(if [null? args]
#f
[let ([val (myeval (car args) env)])
(if val
val
(evor (cdr args) env))]))
(define (eval-args args env)
(cond
[(null? args) '()]
[else (cons (myeval (car args) env)
(eval-args (cdr args) env))]))
(define (myapply func vals)
(cond
[(eq? (first (func)) 'primitive)
(apply-primitive (second (func)) vals)]
[(eq? (first (func)) 'non-primitive)
(eval-sequence (third (func))
(extend-env
(second (func))
vals
(fourth (func))))]
[else (error func "unexpected case in myapply")]))
(define (apply-primitive name vals)
(cond
[(eq? name 'void) (void)]
[(eq? name 'void?) (void? (first vals))]
[(eq? name 'null?) (null? (first vals))]
[(eq? name 'member) (member (first vals) (second vals))]
[(eq? name 'pair?) (pair? (first vals))]
[(eq? name 'list)
(begin
(define (helper vals)
(if [null? vals]
'()
[cons (car vals) (helper (cdr vals))]))
(helper vals))]
[(eq? name 'cons) (cons (first vals) (second vals))]
[(eq? name 'car) (car (first vals))]
[(eq? name 'cdr) (cdr (first vals))]
[(eq? name 'cddr) (cddr (first vals))]
[(eq? name 'mpair?) (mpair? (first vals))]
[(eq? name 'mcons) (mcons (first vals) (second vals))]
[(eq? name 'mcar) (mcar (first vals))]
[(eq? name 'mcdr) (mcdr (first vals))]
[(eq? name 'set-mcar!) (set-mcar! (first vals) (second vals))]
[(eq? name 'set-mcdr!) (set-mcdr! (first vals) (second vals))]
[(eq? name 'first) (first (first vals))]
[(eq? name 'second) (second (first vals))]
[(eq? name 'third) (third (first vals))]
[(eq? name 'fourth) (fourth (first vals))]
[(eq? name 'boolean?) (boolean? (first vals))]
[(eq? name 'false?) (false? (first vals))]
[(eq? name 'not) (not (first vals))]
[(eq? name 'number?) (number? (first vals))]
[(eq? name '=)
(begin
(define (helper x l)
(cond
[(null? l) #t]
[(= (car l) x) (helper x (cdr l))]
[else #f]))
(if [or (null? vals)
(null? (cdr vals))]
[error "="
"arity mismatch; expects at least 2 arguments."]
[helper (car vals) (cdr vals)]))]
[(eq? name '+) (foldl + 0 vals)]
[(eq? name '-) (- (car vals) (foldl + 0 (cdr vals)))]
[(eq? name '*) (foldl * 1 vals)]
[(eq? name '/) (/ (car vals) (foldl * 1 (cdr vals)))]
[(eq? name 'expt) (expt (first vals) (second vals))]
[(eq? name 'string?) (string? (first vals))]
[(eq? name 'symbol?) (symbol? (first vals))]
[(eq? name 'eq?) (eq? (first vals) (second vals))]
[(eq? name 'equal?) (equal? (first vals) (second vals))]
[(eq? name 'foldl) (foldl (first vals)
(second vals)
(third vals))]
[(eq? name 'error) (error (first vals) (second vals))]))
(eval-sequence lines global-env)
)
(eeval
'(
(define (even? n)
(if [= n 0]
#t
[odd? (- n 1)]))
(define (odd? n)
(if [= n 0]
#f
[even? (- n 1)]))
(define x #f)
(set! x (even? 6))
x
))
#lang racket
(require "interpreter.rkt")
(eeval
'(
(define (eeval lines) ... ) ;; copy paste code from interpreter.rkt
))
#lang R5RS
(#%provide eeval)
(define (eeval lines)
(define first car)
(define second cadr)
(define third caddr)
(define fourth cadddr)
(define (foldl proc init lst)
(cond
((null? lst) init)
(else (foldl proc (proc (car lst) init) (cdr lst)))))
; returns (key . val) if key in frame, #f otherwise
(define (lookup-in-frame key frame)
(cond
((null? frame) #f)
((eq? key (car (car frame))) (car frame))
(else (lookup-in-frame key (cdr frame)))))
; returns (key . val) if key in env, #f otherwise
(define (lookup-in-env key env)
(cond
((null? env) #f)
(else (let ((key-val-pair (lookup-in-frame key (car env))))
(if key-val-pair
key-val-pair
(lookup-in-env key (cdr env)))))))
(define (add-to-env! key value env)
(set-car! env
(cons (cons key value)
(car env))))
(define (update-env! key value env)
(cond
((null? env)
(myerror "set!: assignment disallowed; cannot set variable before its definition \nvariable:" key))
(else (let ((key-val-pair (lookup-in-frame key (car env))))
(if key-val-pair
(set-cdr! key-val-pair value)
(update-env! key value (cdr env)))))))
(define (extend-env keys values env)
(define (new-frame keys values)
(cond
((null? keys) '())
(else (cons (cons (car keys) (car values))
(new-frame (cdr keys) (cdr values))))))
(cons (new-frame keys values) env))
(define global-env (cons '() '()))
(define (myeval expr env)
(cond
((and (not (null? expr)) (not (pair? expr)))
(cond
((boolean? expr) expr)
((number? expr) expr)
((string? expr) expr)
((symbol? expr)
(let ((key-value (lookup-in-env expr env)))
(if key-value
(cdr key-value)
(if (member expr
'(member null? pair?
list cons car cdr cddr
set-car! set-cdr!
cadr caddr cadddr
boolean? not
number? = + - * / expt
string?
symbol? eq? equal?
display))
(lambda () (list 'primitive expr))
(myerror expr "undefined")))))))
((null? expr) (myerror "()" "missing procedure expression."))
((eq? (car expr) 'quote)
(second expr))
((eq? (car expr) 'lambda)
(lambda () (list 'non-primitive
(second expr)
(cddr expr)
env)))
((eq? (car expr) 'define)
(if (not (pair? (second expr)))
(if (lookup-in-frame (second expr) (car env))
(myerror "duplicate definition for identifier in"
(second expr))
(add-to-env! (second expr) (myeval (third expr) env) env))
(myeval (list 'define
(car (second expr))
(cons 'lambda
(cons (cdr (second expr))
(cddr expr))))
env)))
((eq? (car expr) 'set!)
(update-env! (second expr)
(myeval (third expr) env)
env))
((eq? (car expr) 'begin)
(eval-sequence (cdr expr) env))
((eq? (car expr) 'cond)
(evcond (cdr expr) env))
((eq? (car expr) 'if)
(myeval (list 'cond
(list (second expr) (third expr))
(list 'else (fourth expr)))
env))
((eq? (car expr) 'and) (evand (cdr expr) env))
((eq? (car expr) 'or) (evor (cdr expr) env))
((eq? (car expr) 'let)
(eval-sequence (cddr expr)
(extend-env
(map first (second expr))
(map second (second expr))
env)))
(else (myapply (myeval (car expr) env)
(eval-args (cdr expr) env)))
))
(define (eval-sequence lines env)
(cond
((not (null? lines))
(if (null? (cdr lines))
(myeval (car lines) env)
(begin (myeval (car lines) env)
(eval-sequence (cdr lines) env))))))
(define (evcond lines env)
(cond
((not (null? lines))
(cond
((eq? 'else (first (car lines)))
(myeval (second (car lines)) env))
((myeval (first (car lines)) env)
(myeval (second (car lines)) env))
(else (evcond (cdr lines) env))))))
(define (evand args env)
(cond
((null? args) #t)
((null? (cdr args)) (myeval (car args) env))
(else (let ((val (myeval (car args) env)))
(if val
(evand (cdr args) env)
#f)))))
(define (evor args env)
(if (null? args)
#f
(let ((val (myeval (car args) env)))
(if val
val
(evor (cdr args) env)))))
(define (eval-args args env)
(cond
((null? args) '())
(else (cons (myeval (car args) env)
(eval-args (cdr args) env)))))
(define (myapply func vals)
(cond
((eq? (first (func)) 'primitive)
(apply-primitive (second (func)) vals))
((eq? (first (func)) 'non-primitive)
(eval-sequence (third (func))
(extend-env
(second (func))
vals
(fourth (func)))))
(else (myerror func "unexpected case in myapply"))))
(define (apply-primitive name vals)
(define (list-helper vals)
(if (null? vals)
'()
(cons (car vals) (list-helper (cdr vals)))))
(define (=helper x l)
(cond
((null? l) #t)
((= (car l) x) (=helper x (cdr l)))
(else #f)))
(cond
((eq? name 'member) (member (first vals) (second vals)))
((eq? name 'null?) (null? (first vals)))
((eq? name 'pair?) (pair? (first vals)))
((eq? name 'list) (list-helper vals))
((eq? name 'cons) (cons (first vals) (second vals)))
((eq? name 'car) (car (first vals)))
((eq? name 'cdr) (cdr (first vals)))
((eq? name 'cddr) (cddr (first vals)))
((eq? name 'set-car!) (set-car! (first vals) (second vals)))
((eq? name 'set-cdr!) (set-cdr! (first vals) (second vals)))
((eq? name 'cadr) (cadr (first vals)))
((eq? name 'caddr) (caddr (first vals)))
((eq? name 'cadddr) (cadddr (first vals)))
((eq? name 'boolean?) (boolean? (first vals)))
((eq? name 'not) (not (first vals)))
((eq? name 'number?) (number? (first vals)))
((eq? name '=)
(if (or (null? vals)
(null? (cdr vals)))
(myerror "="
"arity mismatch; expects at least 2 arguments.")
(=helper (car vals) (cdr vals))))
((eq? name '+) (foldl + 0 vals))
((eq? name '-) (- (car vals) (foldl + 0 (cdr vals))))
((eq? name '*) (foldl * 1 vals))
((eq? name '/) (/ (car vals) (foldl * 1 (cdr vals))))
((eq? name 'expt) (expt (first vals) (second vals)))
((eq? name 'string?) (string? (first vals)))
((eq? name 'symbol?) (symbol? (first vals)))
((eq? name 'eq?) (eq? (first vals) (second vals)))
((eq? name 'equal?) (equal? (first vals) (second vals)))
((eq? name 'display) (display (first vals)))
))
(define (myerror expr1 expr2)
(begin
(display expr1)
(display " ")
(display expr2)
(newline)))
(eval-sequence lines global-env)
)
(eeval
'(
(define (even? n)
(if (= n 0)
#t
(odd? (- n 1))))
(define (odd? n)
(if (= n 0)
#f
(even? (- n 1))))
(define x #f)
(set! x (even? 6))
(display x)
))
#lang R5RS
(#%require "interpreter-r5rs.rkt")
(eeval
'(
(define (eeval lines) ... ) ;; copy paste code from interpreter.rkt
))
#lang racket
(provide eeval)
(define (eeval lines)
;; The global environment is a mutable list of frames,
;; where each frame is a mutable list of
;; mutable variable-value pairs.
;; When a function is called, it creates a new frame
;; which is a mutable list of parameter-argument pairs.
;; Then it mcons the new frame to the enviroment the
;; function was defined in.
(define global-env (mcons '() '()))
; returns (mcons key val) if key in frame, #f otherwise
(define (lookup-in-frame key frame)
(cond
[(null? frame) #f]
[(eq? key (mcar (mcar frame))) (mcar frame)]
[else (lookup-in-frame key (mcdr frame))]))
; returns (mcons key val) if key in env, #f otherwise
(define (lookup-in-env key env)
(cond
[(null? env) #f]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
key-val-pair
(lookup-in-env key (mcdr env))))]))
(define (add-to-env! key value env)
(set-mcar! env
(mcons (mcons key value)
(mcar env))))
(define (update-env! key value env)
(cond
[(null? env)
(error "set!: assignment disallowed; cannot set variable before its definition \nvariable:" key)]
[else (let ([key-val-pair (lookup-in-frame key (mcar env))])
(if key-val-pair
(set-mcdr! key-val-pair value)
(update-env! key value (mcdr env))))]))
(define (extend-env keys values env)
(define (new-frame keys values)
(cond
((null? keys) '())
(else (mcons (mcons (car keys) (car values))
(new-frame (cdr keys) (cdr values))))))
(mcons (new-frame keys values) env))
(define (myeval expr env)
(cond
[(and (not (null? expr)) (not (pair? expr)))
(cond
[(boolean? expr) expr]
[(number? expr) expr]
[(string? expr) expr]
[(symbol? expr)
(let ([key-value (lookup-in-env expr env)])
(if key-value
[mcdr key-value]
[if [member expr
'(void void? null? member
pair? list cons car cdr cddr
mpair? mcons mcar mcdr
set-mcar! set-mcdr!
first second third fourth
boolean? false? not
number? = + - * / expt
string?
symbol? eq? equal?
display error)]
[lambda () (list 'primitive expr)]
[error expr "undefined"]]))])]
[(null? expr) (error "()" "missing procedure expression.")]
[(eq? (car expr) 'quote)
(second expr)]
[(eq? (car expr) 'lambda)
(lambda () (list 'non-primitive
(second expr)
(cddr expr)
env))]
[(eq? (car expr) 'define)
(if [not (pair? (second expr))]
[if [false? (lookup-in-frame (second expr) (mcar env))]
[add-to-env! (second expr) (myeval (third expr) env) env]
[error "duplicate definition for identifier in"
(second expr)]]
[myeval (list 'define
(car (second expr))
(cons 'lambda
(cons (cdr (second expr))
(cddr expr))))
env])]
[(eq? (car expr) 'set!)
(update-env! (second expr)
(myeval (third expr) env)
env)]
[(eq? (car expr) 'begin)
(eval-sequence (cdr expr) env)]
[(eq? (car expr) 'cond)
(evcond (cdr expr) env)]
[(eq? (car expr) 'if)
(myeval (list 'cond
(list (second expr) (third expr))
(list 'else (fourth expr)))
env)]
[(eq? (car expr) 'and) (evand (cdr expr) env)]
[(eq? (car expr) 'or) (evor (cdr expr) env)]
[(eq? (car expr) 'let)
(eval-sequence (cddr expr)
(extend-env
(map first (second expr))
(eval-args (map second (second expr)) env)
env))]
[else (myapply (myeval (car expr) env)
(eval-args (cdr expr) env))]
))
(define (eval-sequence lines env)
(if [null? lines]
[void]
(if [null? (cdr lines)]
[myeval (car lines) env]
[begin (myeval (car lines) env)
(eval-sequence (cdr lines) env)])))
(define (evcond lines env)
(cond
[(null? lines) (void)]
[(eq? 'else (first (car lines)))
(myeval (second (car lines)) env)]
[(myeval (first (car lines)) env)
(myeval (second (car lines)) env)]
[else (evcond (cdr lines) env)]))
(define (evand args env)
(cond
[(null? args) #t]
[(null? (cdr args)) (myeval (car args) env)]
[else [let ([val (myeval (car args) env)])
(if [false? val]
#f
[evand (cdr args) env])]]))
(define (evor args env)
(if [null? args]
#f
[let ([val (myeval (car args) env)])
(if val
val
(evor (cdr args) env))]))
(define (eval-args args env)
(cond
[(null? args) '()]
[else (cons (myeval (car args) env)
(eval-args (cdr args) env))]))
(define (myapply func vals)
(cond
[(eq? (first (func)) 'primitive)
(apply-primitive (second (func)) vals)]
[(eq? (first (func)) 'non-primitive)
(eval-sequence (third (func))
(extend-env
(second (func))
vals
(fourth (func))))]
[else (error func "unexpected case in myapply")]))
(define (apply-primitive name vals)
(cond
[(eq? name 'void) (void)]
[(eq? name 'void?) (void? (first vals))]
[(eq? name 'null?) (null? (first vals))]
[(eq? name 'member) (member (first vals) (second vals))]
[(eq? name 'pair?) (pair? (first vals))]
[(eq? name 'list)
(begin
(define (helper vals)
(if [null? vals]
'()
[cons (car vals) (helper (cdr vals))]))
(helper vals))]
[(eq? name 'cons) (cons (first vals) (second vals))]
[(eq? name 'car) (car (first vals))]
[(eq? name 'cdr) (cdr (first vals))]
[(eq? name 'cddr) (cddr (first vals))]
[(eq? name 'mpair?) (mpair? (first vals))]
[(eq? name 'mcons) (mcons (first vals) (second vals))]
[(eq? name 'mcar) (mcar (first vals))]
[(eq? name 'mcdr) (mcdr (first vals))]
[(eq? name 'set-mcar!) (set-mcar! (first vals) (second vals))]
[(eq? name 'set-mcdr!) (set-mcdr! (first vals) (second vals))]
[(eq? name 'first) (first (first vals))]
[(eq? name 'second) (second (first vals))]
[(eq? name 'third) (third (first vals))]
[(eq? name 'fourth) (fourth (first vals))]
[(eq? name 'boolean?) (boolean? (first vals))]
[(eq? name 'false?) (false? (first vals))]
[(eq? name 'not) (not (first vals))]
[(eq? name 'number?) (number? (first vals))]
[(eq? name '=)
(begin
(define (helper x l)
(cond
[(null? l) #t]
[(= (car l) x) (helper x (cdr l))]
[else #f]))
(if [or (null? vals)
(null? (cdr vals))]
[error "="
"arity mismatch; expects at least 2 arguments."]
[helper (car vals) (cdr vals)]))]
[(eq? name '+) (foldl + 0 vals)]
[(eq? name '-) (- (car vals) (foldl + 0 (cdr vals)))]
[(eq? name '*) (foldl * 1 vals)]
[(eq? name '/) (/ (car vals) (foldl * 1 (cdr vals)))]
[(eq? name 'expt) (expt (first vals) (second vals))]
[(eq? name 'string?) (string? (first vals))]
[(eq? name 'symbol?) (symbol? (first vals))]
[(eq? name 'eq?) (eq? (first vals) (second vals))]
[(eq? name 'equal?) (equal? (first vals) (second vals))]
; [(eq? name 'foldl) (foldl (first vals)
; (second vals)
; (third vals))]
((eq? name 'display) (display (first vals)))
[(eq? name 'error) (error (first vals) (second vals))]))
(define (foldl proc init lst)
(cond
((null? lst) init)
(else (foldl proc (proc (car lst) init) (cdr lst)))))
(define (eval-print-sequence lines)
(if [null? lines]
[void]
[let ([result (myeval (car lines) global-env)])
(if [void? result]
[eval-print-sequence (cdr lines)]
[begin (display result)
(display "\n")
(eval-print-sequence (cdr lines))])]))
(eval-print-sequence lines)
)
(eeval
'(
(define (even? n)
(if [= n 0]
#t
[odd? (- n 1)]))
(define (odd? n)
(if [= n 0]
#f
[even? (- n 1)]))
(define x #f)
(set! x (even? 6))
x
))
我试着换成R5RS，这样就可以把车停下来了！设置cdr！作品我已经摆脱了mcons，mcar，mcdr，set mcar！，设置mcdr！。但是，我仍然收到一条错误消息：；应用：非程序；需要一个可应用于参数的过程；给定：（mcons的expr（mcons的env））；参数…：[none]@user52874好的，原来的问题解决了。你所报告的是一个完全不同的问题，试着隔离它并修复它。提示：您可能试图将非过程调用为过程。@oscar_lopez感谢您提供的提示，但改为mcons和mlist效果不佳。例如，在底部（eeval（define（偶数？n）…））必须更改为（eeval（mlist“define（mlist“偶数”？n）…）。我试过了，它确实产生了正确的结果。然而，代码甚至不再像Scheme程序了。另外，现在要在解释器-test.rkt中进行自我评估，我必须大量修改复制粘贴的代码，这很乏味，并且无论如何都会破坏自我评估解释器的整体功能。