Skip to content
Browse files

ch4

  • Loading branch information...
1 parent e7fad46 commit a824645d19c358a0c78e61db9caa1711c0cd3f7c @flaming0 committed Aug 31, 2012
View
28 ch4/ex4-21.scm
@@ -1,10 +1,36 @@
;; Example 4.21
+;; First lambda applies to 10
+;; Second lambda applies to ft, then ft(ft 10)
+;;
+
((lambda (n)
((lambda (fact)
(fact fact n))
(lambda (ft k)
(if (= k 1)
1
(* k (ft ft (- k 1)))))))
- 10)
+ 10)
+
+((lambda (n)
+ ((lambda (fib)
+ (fib fib n))
+ (lambda (f k)
+ (cond ((= k 0) 0)
+ ((= k 1) 1)
+ (else (+ (f f (- k 1)) (f f (- k 2))))))))
+ 7)
+
+(define (f x)
+ ((lambda (even? odd?)
+ (even? even? odd? x))
+ (lambda (ev? od? n)
+ (if (= n 0) #t (od? ev? od? (- n 1))))
+ (lambda (ev? od? n)
+ (if (= n 0) #f (ev? ev? od? (- n 1))))))
+
+(f 10)
+(f 12)
+(f 7)
+(f 5)
View
3 ch4/ex4-22.scm
@@ -0,0 +1,3 @@
+;; Example 4.22
+
+((let? expr) (analyze (let->combination expr)))
View
1 ch4/ex4-23.scm
@@ -0,0 +1 @@
+;; Example 4.23
View
1 ch4/ex4-24.scm
@@ -0,0 +1 @@
+;; Example 4.24
View
20 ch4/interpreter-cpp/schint/environment.cpp
@@ -0,0 +1,20 @@
+/*
+ * environment.cpp
+ *
+ * Author: flamingo
+ * E-mail: epiforce57@gmail.com
+ */
+
+#include "environment.h"
+
+Environment::Environment(Environment *baseEnv)
+ : m_baseEnvironment(baseEnv)
+{
+}
+
+Environment *globalEnvironment()
+{
+ static Environment globalEnv(nullptr);
+
+ return &globalEnv;
+}
View
28 ch4/interpreter-cpp/schint/environment.h
@@ -0,0 +1,28 @@
+/*
+ * environment.h
+ *
+ * Author: flamingo
+ * E-mail: epiforce57@gmail.com
+ */
+
+#ifndef ENVIRONMENT_H
+#define ENVIRONMENT_H
+
+#include <map>
+#include <string>
+
+class Evaluable;
+
+class Environment
+{
+ Environment *m_baseEnvironment;
+
+ std::map<std::string, Evaluable *> m_frame;
+
+public:
+ Environment(Environment *baseEnv);
+};
+
+Environment *globalEnvironment();
+
+#endif // ENVIRONMENT_H
View
13 ch4/interpreter-cpp/schint/eval.cpp
@@ -0,0 +1,13 @@
+/*
+ * eval.cpp
+ *
+ * Author: flamingo
+ * E-mail: epiforce57@gmail.com
+ */
+
+#include "eval.h"
+
+Evaluable *eval(Evaluable *exp, Environment *env)
+{
+ return exp->eval(env);
+}
View
26 ch4/interpreter-cpp/schint/eval.h
@@ -0,0 +1,26 @@
+/*
+ * eval.h
+ *
+ * Author: flamingo
+ * E-mail: epiforce57@gmail.com
+ */
+
+#ifndef EVAL_H
+#define EVAL_H
+
+#include <string>
+
+class Environment;
+
+class Evaluable
+{
+public:
+ Evaluable() { }
+ virtual ~Evaluable() { }
+
+ virtual Evaluable *eval(Environment *env) = 0;
+};
+
+Evaluable *eval(Evaluable *exp, Environment *env);
+
+#endif // EVAL_H
View
221 ch4/interpreter-cpp/schint/expression.cpp
@@ -0,0 +1,221 @@
+/*
+ * expression.cpp
+ *
+ * Author: flamingo
+ * E-mail: epiforce57@gmail.com
+ */
+
+#include "expression.h"
+#include <algorithm>
+#include <stdexcept>
+
+enum ExpressionType
+{
+ Number,
+ Variable,
+ Quote,
+ Assignment,
+ Definition,
+ If,
+ Lambda,
+ Begin,
+ Application
+};
+
+// REDO!!!!!!!!!!!!!!!!! THIS IS XYNTA
+
+class List
+{
+ std::string m_listString;
+
+ static void makeList(std::string &rawStr)
+ {
+ for (size_t i = 0; i < rawStr.size(); i++)
+ {
+ char &ch = rawStr.at(i);
+ if (i != std::string::npos && i != 0)
+ {
+ if (std::isspace(ch))
+ {
+ const char &prevCh = rawStr.at(i - 1);
+ const char &nextCh = rawStr.at(i + 1);
+
+ if (prevCh == '(' || nextCh == ')' || prevCh == ' ' || nextCh == ' ')
+ {
+ rawStr.erase(i, 1); i--;
+ }
+ }
+ }
+ }
+ }
+
+public:
+ List(const std::string &str) : m_listString(str)
+ {
+ if (str.empty() || str[0] != '(' || str[str.size() - 1] != ')')
+ throw std::runtime_error("Bad expression.");
+ makeList(m_listString);
+ }
+
+ ExpressionType type() const
+ {
+ std::string tag = car(*this).string();
+
+ if (tag == "\'")
+ return Quote;
+ if (tag == "set!")
+ return Assignment;
+ if (tag == "define")
+ return Definition;
+ if (tag == "if")
+ return If;
+ if (tag == "lambda")
+ return Lambda;
+ if (tag == "begin")
+ return Begin;
+// if (tag == number);
+// if (tag == symbol);
+// if (tag == pair);
+
+ throw std::runtime_error(std::string("Unknown expression type ") + tag + " .");
+ }
+
+ // REDO!!!!!!!!!!!!!!!!! THIS IS XYNTA
+
+ static List car(const List &lst)
+ {
+ if (lst.string() == "()" || lst.string().at(0) != '(')
+ throw std::runtime_error("Unable to get car.");
+ return List(lst.string().substr(1, lst.string().find(' ') - 1));
+ }
+
+ static List cdr(const List &lst)
+ {
+ std::string res = std::string("(") + lst.string().substr(lst.string().find(' '));
+ makeList(res);
+ return List(res);
+ }
+
+ std::string string() const { return m_listString; }
+};
+
+Expression::Expression()
+{
+}
+
+Expression *Expression::createExpression(const std::string &str)
+{
+ List expr(str);
+ ExpressionType exprType = expr.type();
+
+ if (exprType == Quote)
+ return new QuotedExpression(List::car(List::cdr(expr)).string());
+ if (exprType == Assignment)
+ return new AssignmentExpression("");
+ if (exprType == Definition)
+ return new DefinitionExpression("");
+ if (exprType == If)
+ return new IfExpression("");
+ if (exprType == Lambda)
+ return new LambdaExpression("");
+ if (exprType == Begin)
+ return new BeginExpression("");
+
+ return nullptr;
+}
+
+VariableExpression::VariableExpression(const std::string &value)
+{
+}
+
+Expression *VariableExpression::eval(Environment *env)
+{
+}
+
+std::string VariableExpression::toString() const
+{
+}
+
+QuotedExpression::QuotedExpression(const std::string &value)
+{
+}
+
+Expression *QuotedExpression::eval(Environment *env)
+{
+}
+
+std::string QuotedExpression::toString() const
+{
+}
+
+AssignmentExpression::AssignmentExpression(const std::string &value)
+{
+}
+
+Expression *AssignmentExpression::eval(Environment *env)
+{
+}
+
+std::string AssignmentExpression::toString() const
+{
+}
+
+DefinitionExpression::DefinitionExpression(const std::string &value)
+{
+}
+
+Expression *DefinitionExpression::eval(Environment *env)
+{
+}
+
+std::string DefinitionExpression::toString() const
+{
+}
+
+IfExpression::IfExpression(const std::string &value)
+{
+}
+
+Expression *IfExpression::eval(Environment *env)
+{
+}
+
+std::string IfExpression::toString() const
+{
+}
+
+LambdaExpression::LambdaExpression(const std::string &value)
+{
+}
+
+Expression *LambdaExpression::eval(Environment *env)
+{
+}
+
+std::string LambdaExpression::toString() const
+{
+}
+
+BeginExpression::BeginExpression(const std::string &value)
+{
+}
+
+Expression *BeginExpression::eval(Environment *env)
+{
+}
+
+std::string BeginExpression::toString() const
+{
+}
+
+ApplicationExpression::ApplicationExpression(const std::string &value)
+{
+}
+
+Expression *ApplicationExpression::eval(Environment *env)
+{
+}
+
+std::string ApplicationExpression::toString() const
+{
+}
View
151 ch4/interpreter-cpp/schint/expression.h
@@ -0,0 +1,151 @@
+/*
+ * expression.h
+ *
+ * Author: flamingo
+ * E-mail: epiforce57@gmail.com
+ */
+
+#ifndef EXPRESSION_H
+#define EXPRESSION_H
+
+#include "eval.h"
+
+class Expression : public Evaluable
+{
+public:
+ Expression();
+
+ static Expression *createExpression(const std::string &str);
+
+ virtual std::string toString() const = 0;
+};
+
+/**
+ * Number.
+ */
+template<typename T>
+class NumberExpression : public Expression
+{
+ T m_value;
+public:
+ NumberExpression(T value)
+ {
+ m_value = value;
+ }
+
+ virtual std::string toString() const
+ {
+ return std::to_string(m_value);
+ }
+
+ Evaluable *eval(Environment *env)
+ {
+ return nullptr;
+ }
+};
+
+/**
+ * Variable.
+ */
+class VariableExpression : public Expression
+{
+public:
+ VariableExpression(const std::string &value);
+
+ virtual Expression *eval(Environment *env);
+
+ virtual std::string toString() const;
+};
+
+/**
+ * Quotation.
+ */
+class QuotedExpression : public Expression
+{
+public:
+ QuotedExpression(const std::string &value);
+
+ virtual Expression *eval(Environment *env);
+
+ virtual std::string toString() const;
+};
+
+/**
+ * Assignment.
+ */
+class AssignmentExpression : public Expression
+{
+public:
+ AssignmentExpression(const std::string &value);
+
+ virtual Expression *eval(Environment *env);
+
+ virtual std::string toString() const;
+};
+
+/**
+ * Definition.
+ */
+class DefinitionExpression : public Expression
+{
+public:
+ DefinitionExpression(const std::string &value);
+
+ virtual Expression *eval(Environment *env);
+
+ virtual std::string toString() const;
+};
+
+/**
+ * If expression.
+ */
+class IfExpression : public Expression
+{
+public:
+ IfExpression(const std::string &value);
+
+ virtual Expression *eval(Environment *env);
+
+ virtual std::string toString() const;
+};
+
+/**
+ * Lambda expression.
+ */
+class LambdaExpression : public Expression
+{
+public:
+ LambdaExpression(const std::string &value);
+
+ virtual Expression *eval(Environment *env);
+
+ virtual std::string toString() const;
+};
+
+/**
+ * Begin expression.
+ */
+class BeginExpression : public Expression
+{
+public:
+ BeginExpression(const std::string &value);
+
+ virtual Expression *eval(Environment *env);
+
+ virtual std::string toString() const;
+};
+
+/**
+ * Application expression.
+ */
+class ApplicationExpression : public Expression
+{
+public:
+ ApplicationExpression(const std::string &value);
+
+ virtual Expression *eval(Environment *env);
+
+ virtual std::string toString() const;
+};
+
+#endif // EXPRESSION_H
View
49 ch4/interpreter-cpp/schint/main.cpp
@@ -1,10 +1,53 @@
#include <iostream>
+#include <string>
+#include <stdexcept>
-using namespace std;
+#include "expression.h"
+#include "environment.h"
-int main()
+std::string readExpression()
{
- cout << "Hello World!" << endl;
+ std::string input;
+ std::cin >> input;
+ return input;
+}
+
+void promtOutput(const Expression *exp)
+{
+ exp->toString();
+}
+
+int main() try
+{
+ bool exit = false;
+
+ std::string input;
+ Expression *exp;
+
+ while (!exit)
+ {
+// input = readExpression();
+ exp = Expression::createExpression("( '\( x 2))"/*input*/);
+
+// Expression *output = static_cast<Expression *>(eval(exp, globalEnvironment()));
+// promtOutput(output);
+
+ delete exp;
+// delete output;
+ }
+
+ delete exp;
+
return 0;
}
+catch (std::exception &ex)
+{
+ std::cerr << "Error: " << ex.what() << " Aborting.\n";
+ return 1;
+}
+catch (...)
+{
+ std::cerr << "Unknown error\n";
+ return 1;
+}
View
12 ch4/interpreter-cpp/schint/schint.pro
@@ -2,5 +2,15 @@ TEMPLATE = app
CONFIG += console
CONFIG -= qt
-SOURCES += main.cpp
+QMAKE_CXXFLAGS += -std=gnu++0x
+
+SOURCES += main.cpp \
+ eval.cpp \
+ environment.cpp \
+ expression.cpp
+
+HEADERS += \
+ eval.h \
+ environment.h \
+ expression.h
View
4 ch4/test-suite-4-24.scm
@@ -0,0 +1,4 @@
+(define (fact n)
+ (if (= n 0)
+ 1
+ (* n (fact (- n 1)))))
View
11 ch4/test_interpreter.scm
@@ -33,6 +33,7 @@
((let? exp) (meval (let->combination (cdr exp)) env))
((let*? exp) (meval (let*->nested-lets (cdr exp)) env))
((letrec? exp) (meval (letrec->let (cdr exp)) env))
+ ((load? exp) (eval-load exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
@@ -245,6 +246,11 @@
(sequence->exp (cond-actions first))
(expand-clauses rest))))))
+;; load
+(define (load? exp) (tagged-list? exp 'load))
+(define (eval-load exp env)
+ (meval (read (open-input-file (cadr exp))) env))
+
;; data structures
(define (true? x)
@@ -344,6 +350,11 @@
(list '- -)
(list '/ /)
(list '* *)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
))
(define (primitive-procedure-names)
View
385 ch4/test_interpreter_analyze.scm
@@ -0,0 +1,385 @@
+(#%require racket/bool)
+
+;; utils
+
+(define apply-in-underlying-scheme apply)
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ #f))
+
+(define (error reason . args)
+ (display "Error: ")
+ (display reason)
+ (for-each (lambda (arg)
+ (display " ")
+ (write arg))
+ args)
+ (newline)
+ (scheme-report-environment -1)) ;; we hope that this will signal an error
+
+;; Eval
+
+(define (meval exp env)
+ ((analyze exp) env))
+
+;; Analyze
+
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((let? expr) (analyze (let->combination expr)))
+ ((if? exp) (analyze-if exp))
+ ((lambda? exp) (analyze-lambda exp))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+;; Analyze impl
+
+(define (analyze-self-evaluating exp)
+ (lambda (env) exp))
+
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env) qval)))
+
+(define (analyze-variable exp)
+ (lambda (env) (lookup-variable-value exp env)))
+
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env)
+ (set-variable-value! var (vproc env) env)
+ 'ok)))
+
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env)
+ (define-variable! var (vproc env) env)
+ 'ok)))
+
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env)
+ (if (true? (pproc env))
+ (cproc env)
+ (aproc env)))))
+
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env) (make-procedure vars bproc env))))
+
+(define (analyze-sequence exps)
+ (define (sequentially proc1 proc2)
+ (lambda (env) (proc1 env) (proc2 env)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc ;; only one combination
+ (loop (sequentially first-proc (car rest-procs)) ;; otherwise, loop through combinations
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env)
+ (execute-application (fproc env)
+ (map (lambda (aproc) (aproc env))
+ aprocs)))))
+
+(define (execute-application proc args)
+ (cond ((primitive-procedure? proc)
+ (apply-primitive-procedure proc args))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))))
+ (else
+ (error "Unknown procedure type -- EXECUTE-APPLICATION" proc))))
+
+;; From the old interpreter
+
+;; Syntax
+
+;; self-evaluating - only numbers and strings
+(define (self-evaluating? exp)
+ (cond ((number? exp) #t)
+ ((string? exp) #t)
+ (else #f)))
+
+;; var = symbol
+(define (variable? exp) (symbol? exp))
+
+;; quotation
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+
+;; definition of vars and procs
+(define (definition? exp)
+ (tagged-list? exp 'define))
+
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp) ;; define variable
+ (caadr exp))) ;; define procedure
+
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp) ;; value for variable
+ (make-lambda (cdadr exp) ;; value for procedure
+ (cddr exp))))
+
+;; lambdas
+(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)))
+
+;; if stuff
+(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))
+
+;; let stuff
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-body exp) (cdr exp))
+(define (let-vars-and-exps exp) (car exp))
+(define (let-vars exp)
+ (if (null? exp)
+ '()
+ (cons (caar exp) (let-vars (cdr exp)))))
+(define (let-exps exp)
+ (if (null? exp)
+ '()
+ (cons (cadar exp) (let-exps (cdr exp)))))
+(define (let->combination exp)
+ (cons (make-lambda (let-vars (let-vars-and-exps exp)) (let-body exp))
+ (let-exps (let-vars-and-exps exp))))
+
+;; begin
+(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))
+
+;; procedure invocation
+(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))
+
+;; compound cond
+(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 "Clause else not the last" clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+
+;; data structures
+
+(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))
+
+;; environment
+
+;; environment is the list of frames
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+
+;; frame is the two lists: list of variables and list of values
+(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))) ;; mutable append (frame = x + frame)
+ (set-cdr! frame (cons val (cdr frame))))
+
+;; create new frame(vars, vals) and ptr to base env
+(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? (car vars) '*unassigned)
+ (error "Unassigned variable -- LOOKUP" var))
+ ((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 (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 '* *)
+ ))
+
+(define (primitive-procedure-names)
+ (map car primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc))) primitive-procedures))
+
+(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 the-global-environment (setup-environment))
+
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme (primitive-implementation proc) args))
+
+;; driver loop
+
+(define input-promt ";;; M-Eval input:")
+(define output-promt ";;; M-Eval value:")
+
+(define (driver-loop)
+ (promt-for-input input-promt)
+ (let ((input (read)))
+ (let ((output (meval input the-global-environment)))
+ (announce-output output-promt)
+ (user-print output)))
+ (driver-loop))
+
+(define (promt-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)))
+
+the-global-environment
+(driver-loop)

0 comments on commit a824645

Please sign in to comment.
Something went wrong with that request. Please try again.