(load "front-end.ss") (load "finite-fun.ss") (load "cells.ss") ;;;----------------------------------------------------------- ;;; ABSTRACT SYNTAX (define-record lit (datum)) (define-record varref (var)) (define-record app (rator rands)) (define-record if (test-exp then-exp else-exp)) (define-record let (decls body)) (define-record proc (formals body)) (define-record varassign (var exp)) (define-record begin (exp1 exp2)) (define-record prim-proc (prim-op)) (define-record closure (formals body env)) (define-record decl (var exp)) (define-record letrecproc (procdecls body)) (define-record procdecl (var formals body)) ;;;----------------------------------------------------------- ;;; FUNCTIONS FOR THE ENVIRONMENTS (define the-empty-env (create-empty-ff)) (define extend-env extend-ff*) (define apply-env apply-ff) ;;;----------------------------------------------------------- ;;; FUNCTIONS FOR EVAL-EXP (define eval-exp (lambda (exp env) (variant-case exp (lit (datum) datum) (varref (var) (cell-ref (apply-env env var))) (app (rator rands) (let ((proc (eval-exp rator env)) (args (eval-rands rands env))) (apply-proc proc args))) (if (test-exp then-exp else-exp) (if (true-value? (eval-exp test-exp env)) (eval-exp then-exp env) (eval-exp else-exp env))) (let (decls body) (let ((vars (map decl->var decls)) (exps (map decl->exp decls))) (let ((new-env (extend-env vars (eval-rands exps env) env))) (eval-exp body new-env)))) (proc (formals body) (make-closure formals body env)) (varassign (var exp) (let ((l-val (apply-env env var)) (r-val (eval-exp exp env))) (cell-set! l-val r-val) r-val)) (begin (exp1 exp2) (eval-exp exp1 env) (eval-exp exp2 env)) (letrecproc (procdecls body) (let ((names (map procdecl->var procdecls))) (let ((new-env (extend-env names (map (lambda (x) (make-cell '*dummy*)) names) env))) (foreach (lambda (procdecl) (let ((name (procdecl->var procdecl)) (formals (procdecl->formals procdecl)) (body (procdecl->body procdecl))) (cell-set! (apply-env new-env name) (make-closure formals body new-env)))) procdecls) (eval-exp body new-env)))) (else (error "Invalid abstract syntax: " exp))))) (define eval-rands (lambda (rands env) (map (eval-rand env) rands))) (define eval-rand (lambda (env) (lambda (exp) (make-cell (eval-exp exp env))))) ;;;----------------------------------------------------------- ;;; FUNCTIONS FOR PROCEDURES (define apply-proc (lambda (proc args) (variant-case proc (prim-proc (prim-op) (apply-prim-op prim-op (map cell-ref args))) (closure (formals body env) (eval-exp body (extend-env formals args env))) (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)) (else (error "Invalid prim-op name:" prim-op))))) (define prim-op-names '(+ - * add1 sub1 zero)) ;;;----------------------------------------------------------- ;;; FUNCTIONS FOR INIT-ENV (define init-env (extend-env prim-op-names (map make-cell (map make-prim-proc prim-op-names)) the-empty-env)) ;;;----------------------------------------------------------- ;;; FUNCTIONS FOR MISC AUXILLARY SERVICES (define true-value? (lambda (x) (not (zero? x)))) (define foreach (lambda (proc lst) (if (null? lst) 'done (begin (proc (car lst)) (foreach proc (cdr lst)))))) ;;;----------------------------------------------------------- ;;; FUNCTIONS FOR READ-EVAL-PRINT (define parse (lambda (s) (if (string? s) (character-string-parser s) (error "You need to enter a string!!!" s)))) (define run (lambda (x) (eval-exp (parse x) init-env))) (define read-eval-print (lambda () (display "--> ") (write (eval-exp (parse (read)) init-env)) (newline) (read-eval-print)))