Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 057c5467d4
Fetching contributors…

Cannot retrieve contributors at this time

297 lines (228 sloc) 7.982 kb
#lang scheme
(include "shared-stuff.scm")
;(define (eval exp env)
; (cond ((self-evaluating? exp) exp)
; ((variable? exp) (lookup-variable-value exp env))
; ((quoted? exp) (text-of-quotation exp))
; ((assignment? exp) (eval-assignment exp env))
; ((definition? exp) (eval-definition exp env))
; ((if? exp) (eval-if 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 (eval (operator exp) env)
; (list-of-values (operands exp) env)))
; (else
; (error "Unknown expression type - EVAL" exp))))
;(define (deriv exp var)
; (cond ((number? exp) 0)
; ((variable? exp) (if (same-variable? exp var) 1 0))
; (else ((get (operator exp) 'deriv) (operands exp)
; var))))
(define (eval exp env)
; get the operator for this expression if there is one
(let ((operator
(if (pair? exp)
(get (car exp))
#f)))
(cond ((operator (operator exp env)))
((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type - EVAL" exp)))))
(put 'quote (lambda (exp env)
(text-of-quotation exp)))
(put 'set! (lambda (exp env)
(eval-assignment exp env)))
(put 'define (lambda (exp env)
(eval-definition exp env)))
(put 'if (lambda (exp env)
(eval-if exp env)))
(put 'lambda (lambda (exp env)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env)))
(put 'begin (lambda (exp env)
(eval-sequence (begin-actions exp) env)))
(put 'cond (lambda (exp env)
(eval (cond->if exp) env)))
(put 'and (lambda (exp env)
(eval-and exp env)))
(put 'or (lambda (exp env)
(eval-or exp env)))
(define lookup-variable-value '())
(define primitive-procedure? '())
(define apply-primitive-procedure '())
(define compound-procedure? '())
(define procedure-body '())
(define procedure-parameters '())
(define procedure-environment '())
(define true? '())
(define extend-environment '())
(define set-variable-value! '())
(define assignment-variable '())
(define define-variable! '())
(define sequence->exp '())
(define (apply procedure arguments)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure procedure arguments))
((compound-procedure? procedure)
(eval-sequence
(procedure-body procedure)
(extend-environment
(procedure-parameters procedure)
arguments
(procedure-environment procedure))))
(else
(error
("Unknown procedure type - APPLY" procedure)))))
(define (list-of-values exps env)
(if (no-operands? exps)
'()
(cons (eval (first-operand exps) env)
(list-of-values (rest-operands exps) env))))
(define (eval-and exp env)
(let ((first (eval (cadr exp) env)))
(if (eq? first #f)
first
(eval (caddr exp) env))))
(define (eval-or exp env)
(let ((first (eval (cadr exp) env)))
(if (eq? first #f)
(eval (caddr exp) env)
first)))
(define (eval-if exp env)
(if (true? (eval (if-predicate exp) env))
(eval (if-consequent exp) env)
(eval (if-alternative exp) env)))
(define (eval-sequence exps env)
(cond ((last-exp? exps) (eval (first-exp exps) env))
(else (eval (first-exp exps) env)
(eval-sequence (rest-exps exps) env))))
(define (eval-assignment exp env)
(set-variable-value! (assignment-variable exp)
(eval (assignment-value exp) env)
env)
'ok)
(define (eval-definition exp env)
(define-variable! (definition-variable exp)
(eval (definition-value exp) env)
env)
'ok)
(define (self-evaluating? exp)
(cond ((number? exp) true)
((string? exp) true)
(else false)))
(define (variable? exp) (symbol? exp))
(define (quoted? exp)
(tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))
(define (assignment? exp)
(tagged-list? exp 'set!))
(define (assigment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
(define (definition? exp)
(tagged-list? exp 'define))
(define (definition-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp)))
(define (definition-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp)
(cddr exp))))
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (not (null? (cdddr exp)))
(cadddr exp)
'false))
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (sequence-exp seq)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(else (make-begin seq))))
(define (make-begin seq) (cons 'begin seq))
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clause? clause)
(eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (null? clauses)
'false
(let ((first (car clauses))
(rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence-exp (cond-actions first))
(error "ELSE clause isn't last = COND->IF"
clauses))
(if (and (pair? (cond-actions first)) (eq? (car (cond-actions first)) '=>))
(make-if (cond-predicate first)
((cadr (cond-actions first)) (cond-predicate first))
(expand-clauses rest))
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest)))))))
(define (let->combination exp)
(define (vars pairs)
(map car pairs))
(define (vals pairs)
(map cadr pairs))
(if (eq? (length exp) 3)
(let ((var (cadr exp))
(let-pairs (caddr exp))
(body (cdddr exp)))
(list 'begin
(list 'define var (make-lambda (vars let-pairs) body))
(list var (vals let-pairs))))
(let ((let-pairs (cadr exp))
(body (cddr exp)))
(list
(make-lambda (vars let-pairs) body)
(vals let-pairs)))))
(define (let*->nested-lets exp)
(let ((let-pairs (cadr exp)))
(define (iter pairs)
(if (null? pairs)
'()
(list 'let
(car pairs)
(iter (cdr pairs)))))
(iter let-pairs)))
(eval '(quote 1 2 3) '())
Jump to Line
Something went wrong with that request. Please try again.