; Auxiliar functions ; (define length (l) (if (null? l) 0 (+ 1 (length (cdr l))))) (define caar (l) (car (car l))) (define cadr (l) (car (cdr l))) (define cddr (l) (cdr (cdr l))) (define caddr (l) (car (cdr (cdr l)))) (define cadar (l) (car (cdr (car l)))) (define cadddr (exp) (car (cdr (cdr (cdr exp))))) (define list1 (x) (cons x '())) (define list2 (x y) (cons x (cons y '()))) (define list3 (x y z) (cons x (cons y (cons z '())))) (define or (x y) (if x x y)) (define atom? (x) (or (null? x) (or (number? x) (symbol? x)))) (define equal (l1 l2) (if (atom? l1) (= l1 l2) (if (atom? l2) '() (if (equal (car l1) (car l2)) (equal (cdr l1) (cdr l2)) '())))) (define and (x y) (if x y x)) (define not (x) (if x '() 'T)) (define divides (m n) (= (mod n m) 0)) ; Association Lists ; (define assoc (x alist) (if (null? alist) '() (if (= x (caar alist)) (cadar alist) (assoc x (cdr alist))))) (define mkassoc (x y alist) (if (null? alist) (list1 (list2 x y)) (if (= x (caar alist)) (cons (list2 x y) (cdr alist)) (cons (car alist) (mkassoc x y (cdr alist)))))) ; Unary/Binary operations ; (define apply-binary-op (f x y) (if (= f 'cons) (cons x y) (if (= f '+) (+ x y) (if (= f '-) (- x y) (if (= f '*) (* x y) (if (= f '/) (/ x y) (if (= f '<) (< x y) (if (= f '>) (> x y) (if (= f '=) (= x y) 'error!))))))))) (define apply-unary-op (f x) (if (= f 'car) (car x) (if (= f 'cdr) (cdr x) (if (= f 'number?) (number? x) (if (= f 'list?) (list? x) (if (= f 'symbol?) (symbol? x) (if (= f 'null?) (null? x) 'error!))))))) ; ; Eval: This is the main part ; (define eval (exp rho fundefs) (if (number? exp) exp (if (symbol? exp) (assoc exp rho) (if (= (car exp) 'quote) (cadr exp) (if (= (car exp) 'if) (if (null? (eval (cadr exp) rho fundefs)) (eval (cadddr exp) rho fundefs) (eval (caddr exp) rho fundefs)) (if (userfun? (car exp) fundefs) (apply-userfun (assoc (car exp) fundefs) (evallist (cdr exp) rho fundefs) fundefs) (if (= (length exp) 2) (apply-unary-op (car exp) (eval (cadr exp) rho fundefs)) (apply-binary-op (car exp) (eval (cadr exp) rho fundefs) (eval (caddr exp) rho fundefs))))))))) (define userfun? (f fundefs) (assoc f fundefs)) (define apply-userfun (fundef args fundefs) (eval (cadr fundef) ; body of function (mkassoc* (car fundef) args '()) ; local env fundefs)) (define evallist (el rho fundefs) (if (null? el) '() (cons (eval (car el) rho fundefs) (evallist (cdr el) rho fundefs)))) (define mkassoc* (keys values al) (if (null? keys) al (mkassoc* (cdr keys) (cdr values) (mkassoc (car keys) (car values) al)))) ; ; This is the READ-EVAL-PRINT LOOP ; (define r-e-p-loop (inputs) (r-e-p-loop* inputs '())) (define r-e-p-loop* (inputs fundefs) (if (null? inputs) '() ; session done (if (atom? (car inputs)) ; input is variable or number (process-exp (car inputs) (cdr inputs) fundefs) (if (= (caar inputs) 'define) ; input is function definition (process-def (car inputs) (cdr inputs) fundefs) (process-exp (car inputs) (cdr inputs) fundefs))))) (define process-def (e inputs fundefs) (cons (cadr e) ; echo function name (r-e-p-loop* inputs (mkassoc (cadr e) (cddr e) fundefs)))) (define process-exp (e inputs fundefs) (cons (eval e '() fundefs) ; print value of expression (r-e-p-loop* inputs fundefs))) ; ; This is one example from the book ; (r-e-p-loop '( (define double (a) (+ a a)) (double (car (quote (4 5)))) (define exp (m n) (if (= n 0) 1 (* m (exp m (- n 1))))) (exp 4 3) )) quit