# Scheme0 Source Code

From the book Compiling Lambda Calculus

Provided under the Creative Commons Zero (CC0) licence

```; 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)```

## Compiler

```(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))
(+ 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))
((eq? 'lambda (car x))
((eq? '%ref (car x))
x)
((eq? 'if (car x))
((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))```

## Interpreter / Abstract Machine

```(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)

(define (push x)
(set! S (cons x S)))

(define (cleanup)
(set! S (cddr S)))

(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)
((eq? '%lambda f)
(make-fun x))
((eq? '%apply f)
(ev-apply x))
((eq? '%tail-apply f)
(ev-tail-apply x))
((eq? '%ref f)