Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
161 lines (136 sloc) 3.5 KB
; Tail-recursive Scheme interpreter
; Uses: startup scmhelp.lsp
; Based on Abelson & Sussman, chapter 5.
; The most glaring omissions are error-checking, set!, begin, and call/cc.
(define next '*)
(define exp '*)
(define env '*)
(define proc '*)
(define rands '*)
(define args '*)
(define value '*)
(define cont '*)
(define read-eval-print-loop
(lambda ()
(while (begin
(write '>)
(not (eq? the-eof-object (set! exp (read)))))
(set! exp (macroexpand exp))
(set! env init-env)
(set! cont (lambda () 'halt))
(set! next eval-exp)
(print value))))
(define run
(lambda ()
(while (not (eq? (next) 'halt)))))
(define goto
(lambda (procedure)
(set! next procedure)))
(define return
(lambda (val)
(set! value val)
(set! next cont)))
(define eval-exp
(lambda ()
(if (atom? exp)
(if (symbol? exp)
(lookup-variable exp env)
(let ((handler (get (car exp) 'evaluator)))
(if handler
(begin ; procedure call
(push cont) ; this eventually is popped by apply-proc
(push env)
(push (cdr exp)) ; save the operands
(set! exp (car exp)) ; evaluate the operator
(set! cont eval-rands)
(goto eval-exp)))))))
(define eval-rands
(lambda ()
(set! rands (pop))
(set! env (pop))
(set! args '())
(push value) ; save the procedure
(goto rands-loop)))
(define rands-loop
(lambda ()
(if (null? rands)
(set! args (reverse! args))
(set! proc (pop))
(goto apply-proc))
(set! exp (car rands))
(push env)
(push args)
(push (cdr rands))
(set! cont add-arg)
(goto eval-exp)))))
(define add-arg
(lambda ()
(set! rands (pop))
(set! args (cons value (pop)))
(set! env (pop))
(goto rands-loop)))
(put 'quote 'evaluator
(lambda ()
(return (cadr exp))))
(put 'lambda 'evaluator
(lambda ()
(return (make-closure exp env))))
(put 'if 'evaluator
(lambda ()
(push cont)
(push env)
(push exp)
(set! cont decide)
(set! exp (test-exp exp))
(goto eval-exp)))
(define decide
(lambda ()
(set! exp (pop))
(set! env (pop))
(set! cont (pop))
(set! exp (if value (then-exp exp) (else-exp exp)))
(goto eval-exp)))
(put 'define 'evaluator
(lambda ()
(push cont)
(push env)
(push (cadr exp)) ; save the variable being defined
(set! exp (caddr exp)) ; evaluate the defining expression
(set! cont do-definition)
(goto eval-exp)))
(define do-definition
(lambda ()
(set! exp (pop))
(set! env (pop))
(set! cont (pop))
(define-variable-value exp value env)
(return exp)))
(define apply-proc
(lambda ()
(set! cont (pop))
(if (primitive? proc)
(return (apply proc args))
(set! exp (closure-body proc))
(set! env
(extend-env (closure-formals proc) args (closure-env proc)))
(goto eval-exp)))))
; Stack operations
(define stack '())
(define push
(lambda (x)
(set! stack (cons x stack))))
(define pop
(lambda ()
(let ((result (car stack)))
(set! stack (cdr stack))
; Here we go
(define init-env (extend-env '() '() '()))
Jump to Line
Something went wrong with that request. Please try again.