(define primitive-procedures
(list (list 'car car)
...
;;; BEGIN: added for problem 1
(list '+ +)
(list '* *)
(list '- -)
(list '/ /)
;;; END: added for problem 1
...
))
Now, when the meta interpreter encounters an application of some values, say `(1 2 3), to the + operator, it will invoke the regular scheme interpreter's + operator.
There are several ways of doing this that limits the number of arguments to + For example you could have replaced the (list `+ +) above with (list `+ (lambda (x y) (+ x y))). There are other alternatives that are even more difficult. These solution are all more difficult than that given above.
;;; M-Eval input: (- 1) ;;; M-Eval value: -1 ;;; M-Eval input: (+ 4 5) ;;; M-Eval value: 9 ;;; M-Eval input: (* 10 11 12) ;;; M-Eval value: 1320 ;;; M-Eval input: (/ 1 10) ;;; M-Eval value: 0.1
;; factorial
(define (factorial n)
(if (= 0 n)
1
(* n (factorial (- n 1)))
)
)
This relies on adding a new primitive = which we added to the primitive-procedures list in the same manner as Problem 1.
'(procedure (x) ((+ 5 x)) <procedure-env>)Well, we will make a traced procedure as follows:
'(traced-procedure (x) ((+ 5 x)) <procedure-env>)Now, we are all set to write code to detect if a procedure is a traced procedure2:
(define (traced-procedure? p) (tagged-list? p 'traced-procedure) )We also modified compound-procedure? as follows:
(define (compound-procedure? p) (or (tagged-list? p 'procedure) (traced-procedure? p)) )because a traced procedure is still a compound procedure.
Note that an equally good solution would be to keep a global list of traced procedures and when my-trace is called on some lambda, that procedure can be added to the global list of traced procedures. When my-untrace is called on that lambda, the global list can be searched and that procedure can be removed.
(define (foo x) (+ x 5)) (define bar foo) (define foo 55) (define trace bar) (bar 10)Here bar will be traced and it will think that its function name is foo. With this model in mind the solution that follows names a procedure by adding a fifth element to the procedure data list, which is the procedures name:
'(procedure (x) ((+ x 5)) <procedure-env> foo)This naming occurs when the lambda is bound to a variable for the first time. So if we are setting a variable to some value and that value happens to be an unnamed lambda, then we will name this lambda with the variable name that we are setting. To do this the following function was defined and a call to it was added to eval-assignment and eval-definition. The code follows:
;; this is added for naming procedures.
;; if the value is a lambda, then we will set the name of
;; of the lambda (the 5th item in the list) if it is not
;; already set to some value.
(define (set-procedure-name-if-necessary var proc)
;; if it is a procedure and its not
;; named, then set the name.
(if (and (compound-procedure? proc)
(not (procedure-named? proc))
)
(set-cdr! (cdddr proc) (list var))
)
)
(define (my-apply procedure arguments)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure procedure arguments))
((compound-procedure? procedure)
;;; BEGIN: added for problem 2.
;; if it is a traced function
;; print out entering info.
(cond ((traced-procedure? procedure)
(display "Entering Procedure: ")
(if (procedure-named? procedure)
(display (procedure-name procedure))
(user-print procedure)
)
(newline)
(display "Arguments:\n")
(vars-vals-print
(procedure-parameters procedure)
arguments
)
)
)
;; invoke procedure. This time though, we will will
;; store the return value in variable 'retval'.
;; we have to save the return value because we
;; want to print it out if this is a traced
;; procedure.
(let ((retval
;;; BEGIN: original code to call a function.
(eval-sequence
(procedure-body procedure)
(extend-environment
(procedure-parameters procedure)
arguments
(procedure-environment procedure)))
)
;;; END: of original code to call function.
;; now the function has returned and we have
;; retval.
)
;; if it is a traced function
;; print exit info.
(cond ((traced-procedure? procedure)
(display "Leaving Procedure: ")
(if (procedure-named? procedure)
(display (procedure-name procedure))
(user-print procedure)
)
(newline)
(display "\tReturning: ")
(user-print retval)
(newline)
)
)
;; return retval
retval
)
;;; END: added for problem 2 and 3.
)
(else
(error
"Unknown procedure type -- APPLY" procedure))))
;; here are my-trace and my-untrace for problem 2. (define (my-trace p) (set-car! p 'traced-procedure) p ; return p ) (define (my-untrace p) (set-car! p 'procedure) p ; return p )
;;; M-Eval input:
(trace factorial)
;;; M-Eval value:
(compound-procedure (n) ((if (= 0 n) 1 (* n (fact...
;;; M-Eval input:
(factorial 3)
Entering Procedure: factorial
Arguments:
n -> 3
Entering Procedure: factorial
Arguments:
n -> 2
Entering Procedure: factorial
Arguments:
n -> 1
Entering Procedure: factorial
Arguments:
n -> 0
Leaving Procedure: factorial
Returning: 1
Leaving Procedure: factorial
Returning: 1
Leaving Procedure: factorial
Returning: 2
Leaving Procedure: factorial
Returning: 6
;;; M-Eval value:
6
;;; for problem 2 and 3.
;; This prints out a variable
;; and value pair in a nice way.
(define (var-val-print var val)
(display "\t")
(display var)
(display "\t->\t")
(user-print val)
(display "\n")
)
;;; for problem 2 and 3.
;; This prints out a lists of variables
;; and values in a nice way.
;; - calls var-val-print
(define (vars-vals-print vars vals)
(map var-val-print vars vals)
)
;;; END: problem 2.
;;; for problem 3. Print the environment.
;; the environment is a list of list.
;; we will print out the first list.
;; then recursively print out the rest.
;; - calls vars-vals-print
(define (env-print env)
(cond ((null? env) '()) ; do nothing on empty list.
(else
(display "Environment[")
(display (length env))
(display "]:\n")
;; first print the first environment.
(let ((frame (first-frame env)))
(vars-vals-print
(frame-variables frame)
(frame-values frame)
)
)
;; print the rest recursively.
(env-print (enclosing-environment env))
)
)
)
(define (traced-procedure? p)
(or (tagged-list? p 'traced-procedure)
(enviro-traced-procedure? p)
)
)
(define (enviro-traced-procedure? p)
(tagged-list? p 'enviro-traced-procedure)
)
;; map: maps function f on list l
(define (map f l)
(if (null? l)
'()
(cons (f (car l)) (map f (cdr l)))
)
)
;; append: append t onto the end of s.
(define (append s t)
( if (null? s)
t
(cons (car s) (append (cdr s) t))
)
)
;;; M-Eval input:
(enviro-trace append)
;;; M-Eval value:
(compound-procedure (s t) ((if (null? s)...
;;; M-Eval input:
(append '(1 2) '(10 11 12))
Entering Procedure: append
Arguments:
s -> (1 2)
t -> (10 11 12)
Environment[1]:
append -> (compound-proced...
map -> (compound-proced...
factorial -> (compoun...
false -> #f
true -> #t
car -> (primitive #[<closure> car])
cdr -> (primitive #[<closure> cdr])
...
= -> (primitive #[<closure> full=?])
null? -> (primitive #[<closure> null?])
env -> (primitive #[<cl...
enviro-trace -> (primiti...
Entering Procedure: append
Arguments:
s -> (2)
t -> (10 11 12)
Environment[1]:
append -> (compound-proced...
map -> (compound-proced...
factorial -> (compoun...
false -> #f
true -> #t
car -> (primitive #[<closure> car])
cdr -> (primitive #[<closure> cdr])
cons -> (primitive #[<closure> cons])
...
env -> (primitive #[<cl...
enviro-trace -> (primiti...
Entering Procedure: append
Arguments:
s -> ()
t -> (10 11 12)
Environment[1]:
append -> (compound-proced...
map -> (compound-proced...
factorial -> (compoun...
false -> #f
true -> #t
car -> (primitive #[<closure> car])
cdr -> (primitive #[<closure> cdr])
...
null? -> (primitive #[<closure> null?])
env -> (primitive #[<cl...
enviro-trace -> (primiti...
Leaving Procedure: append
Returning: (10 11 12)
Leaving Procedure: append
Returning: (2 10 11 12)
Leaving Procedure: append
Returning: (1 2 10 11 12)
;;; M-Eval value:
(1 2 10 11 12)
;;; M-Eval input:
(enviro-trace map)
;;; M-Eval value:
(compound-procedure (f l) ((if (null? ...
;;; M-Eval input:
(map factorial '(0 1))
Entering Procedure: map
Arguments:
f -> (compound-proc...
l -> (0 1)
Environment[1]:
append -> (compound-proc...
map -> (compound-proc...
factorial -> (compo...
false -> #f
true -> #t
car -> (primitive #[<...
...
= -> (primitive #[<...
null? -> (primitive #[<...
env -> (primitive #[<...
enviro-trace -> (primi...
Entering Procedure: factorial
Arguments:
n -> 0
Leaving Procedure: factorial
Returning: 1
Entering Procedure: map
Arguments:
f -> (compound-proc...
l -> (1)
Environment[1]:
append -> (compound-proc...
map -> (compound-proc...
factorial -> (compo...
false -> #f
true -> #t
car -> (primitive #[<...
cdr -> (primitive #[<...
...
env -> (primitive #[<...
enviro-trace -> (primi...
Entering Procedure: factorial
Arguments:
n -> 1
Entering Procedure: factorial
Arguments:
n -> 0
Leaving Procedure: factorial
Returning: 1
Leaving Procedure: factorial
Returning: 1
Entering Procedure: map
Arguments:
f -> (compound-proc...
l -> ()
Environment[1]:
append -> (compound-proc...
map -> (compound-proc...
factorial -> (compo...
false -> #f
true -> #t
car -> (primitive #[<...
...
null? -> (primitive #[<...
env -> (primitive #[<...
enviro-trace -> (primi...
Leaving Procedure: map
Returning: ()
Leaving Procedure: map
Returning: (1)
Leaving Procedure: map
Returning: (1 1)
;;; M-Eval value:
(1 1)
Add special forms for short-circuiting or and and as well as derived, source-to-source, transformations. For brevity we will give a short-circuiting and and a special form for or3.
(define (special-and? exp)
(tagged-list? exp 'special-and)
)
;; this us used for getting all the expressions for
;; a special-and or special-or. returns a list.
(define (special-bool-exps exp)
(cdr exp)
)
;; this does a special-and
(define (eval-special-and exp env)
(letrec ((do-and
(lambda (exps)
(if (null? exps)
true
(and (my-eval (car exps) env)
(do-and (cdr exps))
)
)
)
)
)
(do-and (special-bool-exps exp))
)
)
define (derived-or? exp)
(tagged-list? exp 'derived-or)
)
;; these are the same, lets recycle.
(define derived-bool-exps special-bool-exps)
(define (orexps->if exps)
(if (null? exps)
'false
(make-if (car exps) 'true (orexps->if (cdr exps)))
)
)
;; this makes a huge nested if
(define (or->if exp)
(orexps->if (derived-bool-exps exp))
)
(define (my-eval exp env)
(cond ((self-evaluating? exp) exp)
...
((special-and? exp) (eval-special-and exp env))
((derived-or? exp) (my-eval (or->if exp) env))
...
(else
(error "Unknown expression type -- EVAL" exp))))
;;; M-Eval input: (derived-or false true (/ 1 0)) ;;; M-Eval value: #t ;;; M-Eval input: (special-and true true true false (/ 1 0)) ;;; M-Eval value: #f ;;; M-Eval input: (derived-or false) ;;; M-Eval value: #f ;;; M-Eval input: (derived-or) ;;; M-Eval value: #f ;;; M-Eval input: (special-and) ;;; M-Eval value: #t
Implement let as a source-to-source transformation to lambda
(define (make-combination func args)
(cons func args)
)
(define (let? exp)
(tagged-list? exp 'let)
)
;; the body is the third+ expression(s).
(define (let-body exp)
(cddr exp)
)
;; this gets out the definitions into a list:
;; ((var1 exp1) (var2 exp2) ...)
(define (let-defs-raw exp)
(cadr exp)
)
;; this gets out the definitions from a paired list:
;; ((var1 exp1) (var2 exp2) ...)
;; and puts them into a a pair of list:
;; ((var1 var2 ...) (exp1 exp2 ...)
(define (let-defs-unpair raw)
(if (null? raw)
'( () () ) ; return two empty lists.
(let* ((top (car raw))
(new-var (car top))
(new-val (cadr top))
(the-rest (let-defs-unpair (cdr raw)))
(vars (car the-rest))
(vals (cadr the-rest))
)
(list (cons new-var vars) (cons new-val vals))
)
)
)
;; this gets out the definitions into a list:
;; ((var1 var2 ...) (exp1 exp2 ...)
(define (let-defs exp)
(let-defs-unpair (let-defs-raw exp))
)
;; turn this let into an application of a lambda
(define (let->combination exp)
(let* ((vars-exps (let-defs exp))
(vars (car vars-exps))
(exps (cadr vars-exps))
)
(make-combination
(make-lambda vars (let-body exp))
exps
)
)
)
(define (my-eval exp env)
(cond ((self-evaluating? exp) exp)
...
((let? exp) (my-eval (let->combination exp) env))
...
(else
(error "Unknown expression type -- EVAL" exp))))
;;; M-Eval input: (let ((x 5) (y 10)) (+ x y)) ;;; M-Eval value: 15 ;;; M-Eval input: (let () 1 2 3) ;;; M-Eval value: 3
Define let* as a source-to-source transformation to a chain of nested lets if it is possible.
;; this makes a let for my-eval.
;; vars-exps: ((var1 val1) (var2 val2) ...)
;; body: ((exp1) ...)
(define (make-let vars-exps body)
(append (list 'let vars-exps) body)
)
(define (let*? env)
(tagged-list? env 'let*)
)
;; let* has the same syntax as let,
;; so we will use let's accessor function: let-defs-raw and let-body
(define (let*->nested-lets exp)
(raw-body-let*->nested-lets (let-defs-raw exp) (let-body exp))
)
(define (raw-body-let*->nested-lets raw body)
(if (null? raw)
(make-begin body)
(make-let (list (car raw))
(list (raw-body-let*->nested-lets (cdr raw) body))
)
)
)
(define (my-eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
...
((let*? exp) (my-eval (let*->nested-lets exp) env))
...
(else
(error "Unknown expression type -- EVAL" exp))))
;;; M-Eval input: (let* ((x 5) (y (+ x 10)) (z (+ y 100))) z) ;;; M-Eval value: 115
The entire Homework 2 solution: hw2.s