From the book Compiling Lambda Calculus
Provided under the Creative Commons Zero (CC0) licence
You might prefer to download the source code archive
; Scheme_0 compiler/interpreter with environment propagation ; By Nils M Holm, 2016, 2018 ; ; Provided under the Creative Common Zero (CC0) license ; (https://creativecommons.org/publicdomain/zero/1.0/) ; ; From the book COMPILING LAMBDA CALCULUS, http://t3x.org/clc/ ; Examples: (comp '(((lambda (x) (lambda (y) (cons x y))) 'x) 'y)) ; (evcomp '(((lambda (x) (lambda (y) (cons x y))) 'x) 'y)) (define version 1)
(define (comp x) (define (bind x e n) (cons (cons x n) e)) (define (cconv x e n) (cond ((assq x e) => (lambda (b) `(%ref ,(cdr b)))) ((not (pair? x)) x) ((eq? 'quote (car x)) x) ((eq? 'lambda (car x)) `(lambda ,n ,(cconv (caddr x) (bind (caadr x) e n) (+ 1 n)))) (else (cons (cconv (car x) e n) (cconv (cdr x) e n))))) (define primitives '((cons . 0) (car . 1) (cdr . 2) (pair? . 3) (null? . 4))) (define (closure-conv x) (cconv x '() (length primitives))) (define (comp-expr x t) (cond ((not (pair? x)) x) ((eq? 'quote (car x)) `(%quote ,(cadr x))) ((eq? 'lambda (car x)) `(%lambda ,(cadr x) ,(comp-expr (caddr x) #t))) ((eq? '%ref (car x)) x) ((eq? 'if (car x)) `(%if ,(comp-expr (cadr x) #f) ,(comp-expr (caddr x) t) ,(comp-expr (cadddr x) t))) ((assq (car x) primitives) => (lambda (i) `(%apply (%ref ,(cdr i)) ,@(map (lambda (x) (comp-expr x #f)) (cdr x))))) (else `(,(if t '%tail-apply '%apply) ,@(map (lambda (x) (comp-expr x #f)) x))))) (comp-expr (closure-conv x) #f))
(define (eval x) (define E '#(%cons %car %cdr %pair? %null?)) (define S '()) (define (extend-vector k e) (let ((v (make-vector (+ 1 k)))) (let loop ((i 0)) (if (= i k) v (begin (vector-set! v i (vector-ref e i)) (loop (+ 1 i))))))) (define (make-fun x) `(%fn ,(cadr x) ,(extend-vector (cadr x) E) ,(caddr x))) (define fun-slot cadr) (define fun-env caddr) (define fun-term cadddr) (define (push x) (set! S (cons x S))) (define (cleanup) (set! E (cadr S)) (set! S (cddr S))) (define fun cadr) (define arg caddr) (define *primitives* '(%cons %car %cdr %pair? %null?)) (define (primitive? x) (and (memq x *primitives*) #t)) (define (ev-apply-prim fn a) (cond ((eq? '%cons fn) (cons (ev (car a)) (ev (cadr a)))) ((eq? '%car fn) (car (ev (car a)))) ((eq? '%cdr fn) (cdr (ev (car a)))) ((eq? '%pair? fn) (if (pair? (ev (car a))) 't '())) (else ; %null? (if (null? (ev (car a))) 't '())))) (define (ev-apply x) (let ((fn (ev (fun x)))) (if (primitive? fn) (ev-apply-prim fn (cddr x)) (let ((a (ev (arg x)))) (vector-set! (fun-env fn) (fun-slot fn) a) (push E) (push 'C) (set! E (fun-env fn)) (let ((v (ev (fun-term fn)))) (cleanup) v))))) (define (ev-tail-apply x) (let ((fn (ev (fun x))) (a (ev (arg x)))) (vector-set! (fun-env fn) (fun-slot fn) a) (cleanup) (push E) (push 'C) (set! E (fun-env fn)) (ev (fun-term fn)))) (define (ev x) (let ((f (car x))) (cond ((eq? '%quote f) (cadr x)) ((eq? '%lambda f) (make-fun x)) ((eq? '%apply f) (ev-apply x)) ((eq? '%tail-apply f) (ev-tail-apply x)) ((eq? '%ref f) (vector-ref E (cadr x))) ((eq? '%if f) (if (null? (ev (cadr x))) (ev (cadddr x)) (ev (caddr x)))) (else (error "lc: cannot eval" x))))) (ev x)) (define (evcomp x) (eval (comp x)))