(load "front-end.ss") (load "finite-fun.ss") ;;;----------------------------------------------------------- ;;; ABSTRACT SYNTAX (define-record lit (datum)) (define-record varref (var)) (define-record app (rator rands)) (define-record prim-proc (prim-op)) (define-record if (test-exp then-exp else-exp)) (define-record closure (formals body env)) ;;;----------------------------------------------------------- ;;; FUNCTIONS FOR THE ENVIRONMENTS (define the-empty-env (create-empty-ff)) (define extend-env extend-ff*) (define apply-env apply-ff) ;;;----------------------------------------------------------- ;;; FUNCTIONS FOR THE CONTINUATIONS (define-record final-valcont ()) (define-record proc-valcont (rands env k)) (define-record all-argcont (proc k)) (define-record test-valcont (then-exp else-exp env k)) (define-record first-valcont (rands env k)) (define-record rest-argcont (first k)) (define apply-continuation (lambda (k val) (variant-case k (final-valcont () (let ((final val)) final)) (proc-valcont (rands env k) (let ((proc val)) (eval-rands rands env (make-all-argcont proc k)))) (all-argcont (proc k) (let ((all val)) (apply-proc proc all k))) (test-valcont (then-exp else-exp env k) (let ((test val)) (if (true-value? test) (eval-exp then-exp env k) (eval-exp else-exp env k)))) (first-valcont (rands env k) (let ((first val)) (eval-rands (cdr rands) env (make-rest-argcont first k)))) (rest-argcont (first k) (let ((rest val)) (apply-continuation k (cons first rest))))))) ;;;----------------------------------------------------------- ;;; FUNCTIONS FOR EVAL-EXP (define eval-exp (lambda (exp env k) (variant-case exp (lit (datum) (apply-continuation k datum)) (varref (var) (apply-continuation k (apply-env env var))) (app (rator rands) (eval-exp rator env (make-proc-valcont rands env k))) (if (test-exp then-exp else-exp) (eval-exp test-exp env (make-test-valcont then-exp else-exp env k))) (proc (formals body) (apply-continuation k (make-closure formals body env))) (else (error "Invalid abstract syntax:" exp))))) (define eval-rands (lambda (rands env k) (if (null? rands) (apply-continuation k '()) (eval-exp (car rands) env (make-first-valcont rands env k))))) ;;;----------------------------------------------------------- ;;; FUNCTIONS FOR PROCEDURES (define apply-proc (lambda (proc args k) (variant-case proc (prim-proc (prim-op) (apply-continuation k (apply-prim-op prim-op args))) (closure (formals body env) (eval-exp body (extend-env formals args env) k)) (else (error "Invalid procedure:" proc))))) (define apply-prim-op (lambda (prim-op args) (case prim-op ((+) (+ (car args) (cadr args))) ((-) (- (car args) (cadr args))) ((*) (* (car args) (cadr args))) ((add1) (+ (car args) 1)) ((sub1) (- (car args) 1)) ((zero) (if (zero? (car args)) 1 0)) ((less) (if (< (car args) (cadr args)) 1 0)) ((null) (if (null? args) 1 0)) ((cons) (cons (car args) (cadr args))) ((list) args) ((car) (caar args)) ((cdr) (cdar args)) (else (error "Invalid prim-op name:" prim-op))))) (define prim-op-names '(+ - * add1 sub1 zero less null cons list car cdr)) ;;;----------------------------------------------------------- ;;; FUNCTIONS FOR INIT-ENV (define init-env (extend-env (cons 'emptylist prim-op-names) (cons '() (map make-prim-proc prim-op-names)) the-empty-env)) ;;;----------------------------------------------------------- ;;; FUNCTIONS FOR MISC AUXILLARY SERVICES (define true-value? (lambda (x) (not (zero? x)))) ;;;----------------------------------------------------------- ;;; FUNCTIONS FOR READ-EVAL-PRINT (define run (lambda (x) (eval-exp (parse x) init-env (make-final-valcont)))) (define read-eval-print (lambda () (display "--> ") (write (eval-exp (parse (read)) init-env (make-final-valcont))) (newline) (read-eval-print)))