Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Add 5_50

  • Loading branch information...
commit d671860828e2f54502be14cf8f4ee9fdefbd6b4c 1 parent 0bdff13
@fastred authored
Showing with 5,523 additions and 0 deletions.
  1. +472 −0 5_50.scm
  2. +5,051 −0 mc-eval-compiled-source.scm
View
472 5_50.scm
@@ -0,0 +1,472 @@
+(load "5_43.scm")
+
+(define (let? exp)
+ (tagged-list? exp 'let))
+; we add compilation of let expressions
+(define (compile exp target linkage comp-time-env)
+ (cond ((self-evaluating? exp)
+ (compile-self-evaluating exp target linkage comp-time-env))
+ ((quoted? exp) (compile-quoted exp target linkage comp-time-env))
+ ((variable? exp)
+ (compile-variable exp target linkage comp-time-env))
+ ((let? exp)
+ (compile (let->combination exp) target linkage comp-time-env))
+ ((assignment? exp)
+ (compile-assignment exp target linkage comp-time-env))
+ ((definition? exp)
+ (compile-definition exp target linkage comp-time-env))
+ ((if? exp) (compile-if exp target linkage comp-time-env))
+ ((lambda? exp) (compile-lambda exp target linkage comp-time-env))
+ ((begin? exp)
+ (compile-sequence (begin-actions exp)
+ target
+ linkage comp-time-env))
+ ((cond? exp) (compile (cond->if exp) target linkage comp-time-env))
+ ((application? exp)
+ (compile-application exp target linkage comp-time-env))
+ (else
+ (error "Unknown expression type -- COMPILE" exp))))
+
+; Primitives for EC-Eval
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ ;;above from book -- here are some more
+ (list '+ +)
+ (list '- -)
+ (list '* *)
+ (list '= =)
+ (list '/ /)
+ (list '> >)
+ (list '< <)
+
+ ; almost all of these are used in MC-Eval
+ (list 'apply apply)
+ (list 'list list)
+ (list 'display display)
+ (list 'newline newline)
+ (list 'read read)
+ (list 'pair? pair?)
+ (list 'length length)
+ (list 'eq? eq?)
+ (list 'set-car! set-car!)
+ (list 'set-cdr! set-cdr!)
+ (list 'number? number?)
+ (list 'string? string?)
+ (list 'symbol? symbol?)
+ (list '#t #t)
+ (list '#f #f)
+ (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cdar cdar)
+ (list 'cddr cddr)
+ (list 'caaar caaar)
+ (list 'caadr caadr)
+ (list 'cadar cadar)
+ (list 'caddr caddr)
+ (list 'cdaar cdaar)
+ (list 'cdadr cdadr)
+ (list 'cddar cddar)
+ (list 'cdddr cdddr)
+ (list 'caaaar caaaar)
+ (list 'caaadr caaadr)
+ (list 'caadar caadar)
+ (list 'caaddr caaddr)
+ (list 'cadaar cadaar)
+ (list 'cadadr cadadr)
+ (list 'caddar caddar)
+ (list 'cadddr cadddr)
+ (list 'cdaaar cdaaar)
+ (list 'cdaadr cdaadr)
+ (list 'cdadar cdadar)
+ (list 'cdaddr cdaddr)
+ (list 'cddaar cddaar)
+ (list 'cddadr cddadr)
+ (list 'cdddar cdddar)
+ (list 'cddddr cddddr)
+ (list 'error error)
+ (list 'not not)))
+
+(define mc-eval-source '(begin
+; map is needed for procedures that extend environment
+(define (map proc lis)
+ (cond ((null? lis)
+ '())
+ ((pair? lis)
+ (cons (proc (car lis))
+ (map proc (cdr lis))))))
+
+; MC-Eval source
+(define apply-in-underlying-scheme apply)
+
+(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 (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-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 (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 (variable? exp) (symbol? exp))
+
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+(define (assignment-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))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+
+(define (true? x)
+ (not (eq? x false)))
+
+(define (false? x)
+ (eq? x false))
+
+
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+
+
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+
+(define (enclosing-environment env) (cdr env))
+
+(define (first-frame env) (car env))
+
+(define the-empty-environment '())
+
+(define (make-frame variables values)
+ (cons variables values))
+
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+
+
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+
+(define primitive-procedures
+
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '+ +)
+ (list '- -)
+ (list '* *)
+ (list '/ /)
+ (list '< <)
+ (list '> >)
+ (list '= =)
+ (list 'display display)
+ (list 'list list)
+ (list 'error error)
+ (list 'not not)
+ ))
+
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+; Primitive procedures are encapsulated into lists by EC-Eval, so now we get
+; procedures from these lists.
+(define (primitive-procedure-objects)
+ (map primitive-implementation
+ primitive-procedures))
+
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+(define the-global-environment (setup-environment))
+;(driver-loop)
+
+))
+
+(compile-and-go mc-eval-source)
+
+
+; Sample output:
+
+;;; EC-Eval value:
+ok
+
+;;; EC-Eval input:
+(driver-loop)
+
+
+;;; M-Eval input:
+(define (fib n)
+ (if (< n 2)
+ n
+ (+ (fib (- n 1)) (fib (- n 2)))))
+
+;;; M-Eval value:
+ok
+
+;;; M-Eval input:
+(fib 6)
+
+;;; M-Eval value:
+8
View
5,051 mc-eval-compiled-source.scm
5,051 additions, 0 deletions not shown
Please sign in to comment.
Something went wrong with that request. Please try again.