lisp

solutions to Lisp in Small Pieces
Log | Files | Refs | Feed

commit 0aae214ac6c8b65b1c199c57790e30b05a5b1002
Author: Jenny Doe <tng@soykaf.me>
Date:   Sun,  6 Jan 2019 15:50:50 +0100

first commit

Diffstat:
Achapter1/README.md | 27+++++++++++++++++++++++++++
Achapter1/d.evaluate.scm | 23+++++++++++++++++++++++
Achapter1/d.procedures.scm | 8++++++++
Achapter1/environment.scm | 26++++++++++++++++++++++++++
Achapter1/environment_1-3.scm | 27+++++++++++++++++++++++++++
Achapter1/evaluate.scm | 23+++++++++++++++++++++++
Achapter1/global.scm | 22++++++++++++++++++++++
Achapter1/procedures.scm | 24++++++++++++++++++++++++
Achapter1/s.environment.scm | 8++++++++
Achapter1/s.procedures.scm | 19+++++++++++++++++++
Achapter1/sample-global-environment.scm | 6++++++
11 files changed, 213 insertions(+), 0 deletions(-)

diff --git a/chapter1/README.md b/chapter1/README.md @@ -0,0 +1,27 @@ + $ petite # or chezscheme9.5 + > (load "evaluate.scm") + > (load "sample-global-environment.scm") + > (evaluate '(+ 1 2) env.global) + + + + $ petite # or chezscheme9.5 + > (load "evaluate.scm") + > (evaluate '(begin + (set! f ((lambda (y) + (lambda () y)) + 'lexical)) + + ((lambda (y) + (f)) + 'dynamic)) + + '((f . void))) + 'lexical + > (load "d.evaluate.scm") ; loads d.procedures.scm too + > (evaluate ...) + 'dynamic + > (load "s.procedures.scm") + > (load "s.environment.scm") + > (evaluate ...) + 'dynamic diff --git a/chapter1/d.evaluate.scm b/chapter1/d.evaluate.scm @@ -0,0 +1,23 @@ +(load "d.procedures.scm") + +(define (evaluate exp env) + (if (atom? exp) ; (not (pair? exp)) + (cond + ((symbol? exp) (lookup exp env)) + ((or (number? exp)(string? exp)(char? exp)(vector? exp)) + exp) + (else (error 'evaluate "Invalid atom" exp))) + (case (car exp) + ((quote) (cadr exp)) + ((lambda) (make-function (cadr exp) + (caddr exp) + env)) + ((begin) (eprogn (cdr exp) env)) + ((set!) (update! (cadr exp) (evaluate (caddr exp) env) env)) + ((if) (if (evaluate (cadr exp) env) + (evaluate (caddr exp) env) + (evaluate (cadddr exp) env))) + ;((exit) (exit (cadr exp))) + (else (invoke (evaluate (car exp) env) + (evlist (cdr exp) env) + env))))) diff --git a/chapter1/d.procedures.scm b/chapter1/d.procedures.scm @@ -0,0 +1,8 @@ +(define (invoke proc args current.env) + (if (procedure? proc) + (apply proc args (list current.env)) + (error 'invoke "Not a procedure" proc))) + +(define (make-function bound-names body env) + (lambda (values current.env) + (eprogn (list body) (extend bound-names values current.env)))) diff --git a/chapter1/environment.scm b/chapter1/environment.scm @@ -0,0 +1,26 @@ +(define env.initial '()) + +(define (extend names values env) + (if (pair? names) + (if (pair? values) + (extend (cdr names) (cdr values) + (cons (cons (car names) (car values)) + env)) + (error 'extend "Not enough values" values)) + (if (pair? values) + (error 'extend "Too much values" values) + env))) + +(define (lookup name env) + (if (pair? env) + (if (eq? (caar env) name) + (cdar env) + (lookup name (cdr env))) + (error 'lookup "No such binding" name))) + +(define (update! name new-value env) + (if (pair? env) + (if (eq? (caar env) name) + (set-cdr! (car env) new-value) + (update! name new-value (cdr env))) + (error 'update "No such binding" name))) diff --git a/chapter1/environment_1-3.scm b/chapter1/environment_1-3.scm @@ -0,0 +1,27 @@ +(define env.initial '()) + +(define (extend names values env) + (cons (cons names values) env)) + +(define (lookup name env . set?) + (define (lookup-b names values) + (if (pair? names) + (if (pair? values) + (if (eq? (car names) name) + (if (null? set?) + (car values) + (begin + (set-car! values (car set?)) + (car values))) + (lookup-b (cdr names) (cdr values))) + (error 'lookup "Not enough values" values)) + (if (pair? values) + (error 'lookup "Too much values" values) + #f))) + (if (pair? env) + (let ((x (lookup-b (caar env) (cdar env)))) + (or x (lookup name (cdr env)))) + (error 'lookup "No such binding" name))) + +(define (update! name new-value env) + (lookup name env new-value)) diff --git a/chapter1/evaluate.scm b/chapter1/evaluate.scm @@ -0,0 +1,23 @@ +(load "environment.scm") +(load "procedures.scm") + +(define (evaluate exp env) + (if (atom? exp) ; (not (pair? exp)) + (cond + ((symbol? exp) (lookup exp env)) + ((or (number? exp)(string? exp)(char? exp)(vector? exp)) + exp) + (else (error 'evaluate "Invalid atom" exp))) + (case (car exp) + ((quote) (cadr exp)) + ((lambda) (make-function (cadr exp) + (caddr exp) + env)) + ((begin) (eprogn (cdr exp) env)) + ((set!) (update! (cadr exp) (evaluate (caddr exp) env) env)) + ((if) (if (evaluate (cadr exp) env) + (evaluate (caddr exp) env) + (evaluate (cadddr exp) env))) + ;((exit) (exit (cadr exp))) + (else (invoke (evaluate (car exp) env) + (evlist (cdr exp) env)))))) diff --git a/chapter1/global.scm b/chapter1/global.scm @@ -0,0 +1,22 @@ +(define env.global env.initial) + +(define-syntax definitial + (syntax-rules () + ((_ name) + (begin (set! env.global (cons (cons 'name 'void) + env.global)) + 'name)) + ((_ name value) + (begin (set! env.global (cons (cons 'name value) + env.global)) + 'name)))) + +(define-syntax defprimitive + (syntax-rules () + ((_ name value arity) + (definitial name + (lambda (values) + (if (= arity (length values)) + (apply value values) + (error "Incorrect arity" (list 'name values)))))))) + diff --git a/chapter1/procedures.scm b/chapter1/procedures.scm @@ -0,0 +1,24 @@ +(define (invoke proc args) + (if (procedure? proc) + (apply proc args) + (error 'invoke "Not a procedure" proc))) + +(define (eprogn exps env) + (if (pair? exps) + (if (null? (cdr exps)) + (evaluate (car exps) env) + (begin + (evaluate (car exps) env) + (eprogn (cdr exps) env))) + 'empty-begin)) + +(define (evlist exps env) + (if (pair? exps) + (cons (evaluate (car exps) env) + (evlist (cdr exps) env)) + '())) + +(define (make-function bound-names body env) + (lambda (values) ; values = '(2 3 4) + ; bound-names = '(x y z) + (eprogn (list body) (extend bound-names values env)))) diff --git a/chapter1/s.environment.scm b/chapter1/s.environment.scm @@ -0,0 +1,8 @@ +(define (lookup name env) + (let ((x (getprop 'apval name 'void))) + (if (eq? 'void x) + (error 'lookup "No such binding" name) + x))) + +(define (update! name new-value env) + (putprop 'apval name new-value)) diff --git a/chapter1/s.procedures.scm b/chapter1/s.procedures.scm @@ -0,0 +1,19 @@ +(define (invoke proc args current.env) + (if (procedure? proc) + (apply proc args (list current.env)) + (error 'invoke "Not a procedure" proc))) + +(define (make-function bound-names body env) + (lambda (values current.env) + (let ((old-bindings + (map (lambda (bound-name value) + (let ((old (getprop 'apval bound-name 'void))) + (putprop 'apval bound-name value) + (cons bound-name old))) + bound-names values))) + (begin + (let ((res (eprogn (list body) current.env))) + (for-each (lambda (x) + (putprop 'apval (car x) (cdr x))) + old-bindings) + res))))) diff --git a/chapter1/sample-global-environment.scm b/chapter1/sample-global-environment.scm @@ -0,0 +1,6 @@ +(load "global.scm") + +(defprimitive + + 2) +(defprimitive - - 2) +(defprimitive * * 2) +(defprimitive / / 2)