221 lines
6.9 KiB
Scheme
221 lines
6.9 KiB
Scheme
(load "shared/util.scm")
|
|
(load "shared/sicp-evaluator.scm")
|
|
|
|
(display "\nex-4.31 - explicit-laziness\n")
|
|
|
|
(define (parameter-qualifier parameter)
|
|
(if (pair? parameter) (cadr parameter) 'none))
|
|
|
|
(define (parameter-symbol parameter)
|
|
(if (pair? parameter) (car parameter) parameter))
|
|
|
|
(define (proecure-parameters p) (cadr p))
|
|
|
|
(define (procedure-parameters-only p)
|
|
(map parameter-symbol (cadr p)))
|
|
|
|
(define (list-of-arg-values exps env)
|
|
(if (no-operands? exps)
|
|
'()
|
|
(cons (actual-value (first-operand exps) env)
|
|
(list-of-arg-values (rest-operands exps)
|
|
env))))
|
|
|
|
(define (list? exp)
|
|
(tagged-list? exp 'list))
|
|
|
|
(define (list-elements exp)
|
|
(cdr exp))
|
|
|
|
(define (eval exp env)
|
|
;;(display "EVAL -- ") (display exp) (newline)
|
|
(cond ((self-evaluating? exp) exp)
|
|
((variable? exp) (lookup-variable-value exp env))
|
|
((quoted? exp) (text-of-quotation exp env))
|
|
((assignment? exp) (eval-assignment exp env))
|
|
((definition? exp) (eval-definition exp env))
|
|
((if? exp) (eval-if exp env))
|
|
((list? exp) (eval (list->cons (list-elements exp)) env))
|
|
((lambda? exp)
|
|
(make-procedure (lambda-parameters exp)
|
|
(lambda-body exp)
|
|
env))
|
|
((begin? exp)
|
|
(eval-sequence (begin-actions exp) env))
|
|
((cond? exp) (eval (cond->if exp) env))
|
|
((application? exp)
|
|
(apply (actual-value (operator exp) env)
|
|
(operands exp)
|
|
env))
|
|
(else
|
|
(error "Unknown expression type -- EVAL" exp))))
|
|
|
|
(define (delay-arguments parameters arguments env)
|
|
(define (parameter->arg parameter arg)
|
|
(let ((qualifier (parameter-qualifier parameter)))
|
|
(cond
|
|
((eq? qualifier 'none) (actual-value arg env))
|
|
((eq? qualifier 'lazy) (delay-it arg env))
|
|
((eq? qualifier 'lazy-memo) (delay-it-memo arg env))
|
|
(else (error "unsupported qualifier -- PARAMETER->ARG" qualifier)))))
|
|
(map parameter->arg parameters arguments))
|
|
|
|
(define (apply procedure arguments env)
|
|
(cond ((primitive-procedure? procedure)
|
|
(apply-primitive-procedure
|
|
procedure
|
|
(list-of-arg-values arguments env)))
|
|
((compound-procedure? procedure)
|
|
(eval-sequence
|
|
(procedure-body procedure)
|
|
(extend-environment
|
|
(procedure-parameters-only procedure)
|
|
(delay-arguments (procedure-parameters procedure) arguments env)
|
|
(procedure-environment procedure))))
|
|
(else
|
|
(error
|
|
"Unknown procedure type -- APPLY" procedure))))
|
|
|
|
(define (actual-value exp env)
|
|
(force-it (eval exp env)))
|
|
|
|
(define (force-it obj)
|
|
(if (thunk? obj)
|
|
(actual-value (thunk-exp obj) (thunk-env obj))
|
|
obj))
|
|
|
|
(define (delay-it exp env)
|
|
(list 'thunk exp env))
|
|
|
|
(define (delay-it-memo exp env)
|
|
(list 'thunk-memo exp env))
|
|
|
|
(define (thunk? obj)
|
|
(or (tagged-list? obj 'thunk)
|
|
(tagged-list? obj 'thunk-memo)))
|
|
|
|
(define (thunk-regular? obj)
|
|
(tagged-list? obj 'thunk))
|
|
|
|
(define (thunk-memo? obj)
|
|
(tagged-list? obj 'thunk-memo))
|
|
|
|
(define (thunk-exp thunk) (cadr thunk))
|
|
|
|
(define (thunk-env thunk) (caddr thunk))
|
|
|
|
(define (evaluated-thunk? obj)
|
|
(tagged-list? obj 'evaluated-thunk))
|
|
|
|
(define (thunk-value evaluated-thunk) (cadr evaluated-thunk))
|
|
|
|
(define (force-it obj)
|
|
(cond ((thunk-memo? obj)
|
|
(let ((result (actual-value (thunk-exp obj) (thunk-env obj))))
|
|
(set-car! obj 'evaluated-thunk)
|
|
(set-car! (cdr obj) result) ; replace exp with its value
|
|
(set-cdr! (cdr obj) '()) ; forget unneeded env
|
|
result))
|
|
((evaluated-thunk? obj)
|
|
(thunk-value obj))
|
|
((thunk-regular? obj)
|
|
(actual-value (thunk-exp obj) (thunk-env obj)))
|
|
(else obj)))
|
|
|
|
(let ((the-global-environment (setup-environment)))
|
|
(eval '(define count 0) the-global-environment)
|
|
(eval '(define (id x) (set! count (+ count 1)) x) the-global-environment)
|
|
(eval '(define (square (y lazy-memo)) (* y y)) the-global-environment)
|
|
(assert (eval '(square (id 10)) the-global-environment) 100)
|
|
(assert (eval 'count the-global-environment) 1))
|
|
|
|
(let ((the-global-environment (setup-environment)))
|
|
(eval '(define count 0) the-global-environment)
|
|
(eval '(define (id x) (set! count (+ count 1)) x) the-global-environment)
|
|
(eval '(define (square (y lazy)) (* y y)) the-global-environment)
|
|
(assert (eval '(square (id 10)) the-global-environment) 100)
|
|
(assert (eval 'count the-global-environment) 2))
|
|
|
|
(let ((the-global-environment (setup-environment)))
|
|
(eval '(define count 0) the-global-environment)
|
|
(eval '(define (id x) (set! count (+ count 1)) x) the-global-environment)
|
|
(eval '(define (square y) (* y y)) the-global-environment)
|
|
(assert (eval '(square (id 10)) the-global-environment) 100)
|
|
(assert (eval 'count the-global-environment) 1))
|
|
|
|
(display "\nex-4.32 - lazy-streams\n")
|
|
|
|
(eval
|
|
'(begin
|
|
(define (cons (x lazy-memo) (y lazy-memo))
|
|
(lambda (lazy-list-m) (lazy-list-m x y)))
|
|
(define (car z)
|
|
(z (lambda (p q) p)))
|
|
(define (cdr z)
|
|
(z (lambda (p q) q)))
|
|
(define (list-ref items n)
|
|
(if (= n 0)
|
|
(car items)
|
|
(list-ref (cdr items) (- n 1))))
|
|
(define (map proc items)
|
|
(if (null? items)
|
|
'()
|
|
(cons (proc (car items))
|
|
(map proc (cdr items)))))
|
|
(define (scale-list items factor)
|
|
(map (lambda (x) (* x factor))
|
|
items))
|
|
(define (add-lists list1 list2)
|
|
(cons (+ (car list1) (car list2))
|
|
(add-lists (cdr list1) (cdr list2))))
|
|
(define ones (cons 1 ones))
|
|
(define integers (cons 1 (add-lists ones integers)))
|
|
(define fib (cons 1 (cons 1 (add-lists fib (cdr fib)))))
|
|
)
|
|
the-global-environment)
|
|
|
|
(assert (eval-force '(list-ref fib 10) the-global-environment) 89)
|
|
(assert (eval-force '(list-ref ones 100) the-global-environment) 1)
|
|
|
|
(display "\nex-4.33 - quoted-list\n")
|
|
|
|
(define (list->cons elements)
|
|
(define (make-cons elements)
|
|
(if (null? elements)
|
|
'end
|
|
(list 'cons (car elements)
|
|
(make-cons (cdr elements)))))
|
|
(make-cons elements))
|
|
|
|
(define (text-of-quotation exp env)
|
|
(define (quote-it x)
|
|
(list 'quote x))
|
|
(let ((q (cadr exp)))
|
|
(if (pair? q)
|
|
(eval (list->cons (map quote-it q)) env)
|
|
q)))
|
|
|
|
(assert (eval '(car '(a b c)) the-global-environment) 'a)
|
|
|
|
(display "\nex-4.34 - print-lazy-cons\n")
|
|
|
|
(define (user-print object)
|
|
(cond
|
|
((and (compound-procedure? object)
|
|
(= (length (procedure-parameters object)) 1)
|
|
(eq? (car (procedure-parameters object)) 'lazy-list-m))
|
|
(display "{...}"))
|
|
((compound-procedure? object)
|
|
(display (list 'compound-procedure
|
|
(procedure-parameters object)
|
|
(procedure-body object)
|
|
'<procedure-env>)))
|
|
(else
|
|
(display object))))
|
|
|
|
(user-print (eval 'ones the-global-environment))
|
|
(newline)
|
|
|
|
(display "[done]\n")
|
|
|