4.1 metacircular evaluator

4/1/jord/applyeval.scm

@@ -0,0 +1,278 @@
+(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))
+	((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 (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 (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))
+      (cadr exp)
+      (make-lambda (cdadr exp)   ;; formal params
+		   (cddr exp)))) ;; body
+
+(define (lambda? exp)
+  (tagged-list? exp 'lambda))
+(define (lambda-paramaters 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		; no else clause
+      (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 args supplied" vars vals)
+	  (error "Too few args 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 var" 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 var -- 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?)
+	))
+(define (primitive-procedure-names)
+  (map car
+       primitive-procedures))
+(define (primitive-procedure-objects)
+  (map (lambda (proc) (list 'primitive (cadr proc)))
+       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)))
+
+;; run these after loading this file:
+;(define the-global-environment (setup-environment))
+;(driver-loop)

4/1/jord/lecture.org

@@ -0,0 +1,193 @@
+* Lecture 7A: Metacircular Evaluator, Pt 1
+https://youtu.be/aAlR3cezPJg
+
+yahoo!! excited for this one
+
+gjs: "today we are going to learn about something amazing"
+
+so far, our programs are a character string description of some wiring
+diagram that could also be drawn some other way
+
+we can have something called the "universal machine"
+
+this is "eval"
+
+it is a real machine, we will see it today. remarkably, it fits on the
+blackboard. eval is a machine that takes a description of a machine
+and becomes a simulator of the description.
+
+we are getting real close to the spirit of the computer. to address
+the spirit gjs puts on his jacket and fez.
+
+#+BEGIN_SRC scheme
+  (define eval
+    (λ (exp env)
+      (cond ((number? exp) exp)			;;
+	    ((symbol? exp) (lookup exp env))	;;
+	    ((eq? (car exp) 'quote) (cadr exp))	;;  special
+	    ((eq? (car exp) 'lambda)		;;
+	     (list 'closure (cdr exp) env))	;;   forms
+	    ((eq? (car exp) 'cond)		;;
+	     (evcond (cdr exp) env))		;; ---------
+	    (else (apply (eval (car exp) env)	;;  default
+			 (evlist (cdr exp) env))))))
+#+END_SRC
+
+#+BEGIN_SRC scheme
+  (define apply
+    (λ (proc args)
+      (cond ((primitive? proc)
+	     (apply-primop proc args))
+	    ((eq? (car proc) 'closure)
+	     (eval (cadadr proc)
+		   (bind (caadr proc)
+			 args
+			 (caddr proc))))
+	    (else error))))
+#+END_SRC
+
+#+BEGIN_SRC scheme
+  (define evlist
+    (λ (l env)
+      (cond ((eq? l '()) '())
+	    (else
+	     (cons (eval (car l) env)
+		   (evlist (cdr l) env))))))
+#+END_SRC
+
+#+BEGIN_SRC scheme
+  (define evcond
+    (λ (clauses env)
+      (cond ((eq? clauses '()) '())
+	    ((eq? (caar clauses) 'else)
+	     (eval (cadar clauses) env))
+	    ((false? (eval (caar clauses) env))
+	     (evcond (cdr clauses) env))
+	    (else
+	     (eval (cadar clauses) env)))))
+#+END_SRC
+
+#+BEGIN_SRC scheme
+  (define bind
+    (λ (vars vals env)
+      (cons (pair-up vars vals)
+	    env)))
+  (define pair-up
+    (λ (vars vals)
+      (cond
+       ((eq? vars '())
+	(cond ((eq? vals '()) '())
+	      (else (error TMA))))
+       ((eq? vals '()) (error TFA))
+       (else
+	(cons (cons (car vars)
+		    (car vals))
+	      (pair-up (cdr vars)
+		       (cdr vals)))))))
+  (define lookup
+    (λ (sym env)
+      (cond ((eq? env '()) (error UBV))
+	    (else
+	     ((λ (vcell)
+		(cond ((eq? vcell '())
+		       (lookup sym
+			       (cdr env)))
+		      (else (cdr vcell))))
+	      (assq sym (car env)))))))
+  (define assq
+    (λ (sym alist)
+      (cond ((eq? alist '()) '())
+	    ((eq? sym (caar alist))
+	     (car alist))
+	    (else
+	     (assq sym (cdr alist))))))
+#+END_SRC
+
+--> break
+
+to walk thoroughly thru an example
+
+: (eval '(((λ (x) (λ (y) (+ x y))) 3) 4) <env>)
+
+the environments:
+: e0  |  +  *  -  /  car  cdr  cons  eq?         |
+:     |------------------------------------------|
+
+: (apply (eval '((λ (x) (λ (y) (+ x y))) 3) <e0>)
+:        (evlist '(4) <e0>))
+
+: (apply (eval '((λ (x) (λ (y) (+ x y))) 3) <e0>)
+:        (cons (eval '4 <e0>)
+:              (evlist '() <e0>)))
+
+: (apply (eval '((λ (x) (λ (y) (+ x y))) 3) <e0>)
+:        (cons 4 '()))
+
+: (apply (eval '((λ (x) (λ (y) (+ x y))) 3) <e0>) 
+:        '(4))
+
+: (apply (apply (eval '(λ (y) (λ (y) (+ x y))) <e0>)
+:               '(3))
+:        '(4))
+
+: (apply (apply '(closure ((x) (λ (y) (+ x y))) <e0>)
+:               '(3))
+:        '(4))
+
+:    |-------------------------------------------|
+: e1 | x = 3                             e0      |
+:    |-------------------------------------------|
+
+: (apply (eval '(λ (y) (+ x y)) <e1>)
+:        '(4))
+
+: (apply '(closure ((y) (+ x y)) <e1>)
+:        '(4))
+
+:    |-------------------------------------------|
+: e2 | y = 4                             e1      |
+:    |-------------------------------------------|
+
+: (eval '(+ x y) <e2>)
+
+: (apply (eval '+ <e2>)
+:        (evlist '(x y) <e2>))
+
+: (apply '*add* '(3 4))
+
+: 7
+
+:   +-------------------------------------+
+:   |          proc      args             |
+:   |                                     V
+:  EVAL                                 APPLY
+:   ^                                     |
+:   |          exp        env             |
+:   +-------------------------------------+
+
+
+--> break
+
+consider the following small program:
+#+BEGIN_SRC scheme
+  (define expt
+    (λ (x n)
+      (cond ((= n 0) 1)
+	    (else
+	     (* x (expt x (- n 1)))))))
+#+END_SRC
+
+it's recursive. why does it make sense?
+
+simplest infinite loop:
+: ((λ (x) (x x)) (λ (x) (x x)))
+
+curry's paradoxical combinator Y:
+: (λ (f)
+:   ((λ (x) (f (x x)))
+:    (λ (x) (f (x x)))))
+
+: (y F) = ((λ (x) (F (x x))) (λ (x) (F (x x))))
+:       = (F ((λ (x) (F (x x))) (λ (x) (F (x x)))))
+
+: (y F) = (F (y F))