From: Tim Vaughan <tgvaughan@gmail.com>
Date: Sun, 2 Apr 2017 00:51:18 +0000 (+1200)
Subject: Started porting metacircular evaluator from SICP.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=5c256a740ae9bf1f774e202cbdaf66d8e33f37e7;p=scheme.forth.jl.git

Started porting metacircular evaluator from SICP.
---

diff --git a/examples/metacirc.scm b/examples/metacirc.scm
new file mode 100644
index 0000000..4778591
--- /dev/null
+++ b/examples/metacirc.scm
@@ -0,0 +1,384 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Mandatory SICP Metacircular Evaluator ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define apply-in-underlying-scheme apply)
+
+;; Verbatim code from SICP
+
+(display "eval and apply\n")
+
+(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 (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))
+    (caddr exp)
+    (make-lambda 
+      (cdadr exp)   ; formal parameters
+      (cddr exp)))) ; body
+
+
+(display "lambda... \n")
+
+(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))
+
+
+(display "cond... \n")
+
+(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))
+
+
+(display "make-procedure...\n")
+
+
+(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 '())
+
+
+(display "make-frame\n")
+
+(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))))
+
+(display "extend-environment\n")
+
+(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))))
+
+(display "lookup-variable\n")
+
+(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))
+
+(display "set-variable\n")
+
+(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))
+
+(display "define-variable\n")
+
+(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))))
+
+(display "setup-environment...\n")
+
+(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 '* *)))
+
+(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:")
+
+
+(display "driver-loop...\n") 
+
+
+(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))
diff --git a/src/scheme-library.scm b/src/scheme-library.scm
index 14aa6f8..cd26932 100644
--- a/src/scheme-library.scm
+++ b/src/scheme-library.scm
@@ -13,7 +13,27 @@
 (define (cdar l) (cdr (car l)))
 (define (cddr l) (cdr (cdr l)))
 (define (cadar l) (car (cdr (car l))))
+(define (caddr l) (car (cdr (cdr l))))
+(define (cadddr l) (car (cdr (cdr (cdr l)))))
 
+;; FUNCTIONAL PROGRAMMING
+
+(define (fold-left proc init l)
+  (if (null? l)
+    init
+    (fold-left proc (proc init (car l)) (cdr l))))
+
+(define (reduce-left proc init l)
+  (if (null? l)
+    init
+    (if (null? (cdr l))
+      (car l)
+      (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l))))))
+
+(define (map proc l)
+  (if (null? l)
+    '()
+    (cons (proc (car l)) (map proc (cdr l)))))
 
 ;; NUMBERS
 
@@ -118,18 +138,6 @@
 (define (null? arg)
   (eq? arg '()))
 
-(define (fold-left proc init l)
-  (if (null? l)
-    init
-    (fold-left proc (proc init (car l)) (cdr l))))
-
-(define (reduce-left proc init l)
-  (if (null? l)
-    init
-    (if (null? (cdr l))
-      (car l)
-      (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l))))))
-
 (define (+ . args)
   (fold-left pair+ 0 args))