# Scheme3 Source Code

From the book Compiling Lambda Calculus

Provided under the Creative Commons Zero (CC0) licence

```; Scheme_3 compiler/interpreter (variadic function)
; 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 5)

(define (but-last x)
(reverse (cdr (reverse x))))

(define (last x)
(car (reverse x)))```

## Compiler

```(define (comp x)

(define (flatten x)
(define (f x r)
(cond ((null? x)
r)
((pair? x)
(f (car x)
(f (cdr x) r)))
(else
(cons x r))))
(f x '()))

(define (bind xs e n)
(if (null? xs)
e
(cons (cons (car xs) n)
(bind (cdr xs) e (+ 1 n)))))

(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
,(+ n (length a))
,@(cconv (cddr x)
(bind a e n)
(+ (length a) n)))))
(else
(cons (cconv (car x) e n)
(cconv (cdr x) e n)))))

(define (closure-conv x)
(cconv x '() 0))

(define primitives '((cons  %cons  2)
(car   %car   1)
(cdr   %cdr   1)
(pair? %pair? 1)
(null? %null? 1)))

(define (new-sym i)
(string->symbol (string-append "x" (number->string i))))

(define (prim-fun x)
(let vars ((i (prim-narg x))
(v '()))
(if (zero? i)
(cons '%lambda
(cdr (closure-conv
`(lambda ,v (,(prim-op x) ,@v)))))
(vars (- i 1) (cons (new-sym i) v)))))

(define (comp-expr x t)
(cond ((assq x primitives)
=> prim-fun)
((not (pair? x))
x)
((eq? 'quote (car x))
((eq? 'lambda (car x))
,(if (null? (cdddr x))
(comp-expr (cons 'begin (cddr x)) #t))))
((eq? '%ref (car x))
x)
((eq? 'if (car x))
((eq? 'set! (car x))
((eq? 'begin (car x))
`(%begin ,@(map (lambda (x)
(comp-expr x #f))
(but-last (cdr x)))
,(comp-expr (last x) t)))
((assq (car x) primitives)
=> (lambda (i)
`(,(prim-op 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 '#())
(define S '())

(define (extend-vector ks e)
(n (car ks)))
(let loop ((i 0))
(if (= i n)
v
(begin (vector-set! v i (vector-ref e i))
(loop (+ 1 i)))))))

(define (make-fun x)

(define parm-osize car)

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

(define args cddr)

(define box list)
(define unbox car)

(define (copy-vector! d s n k)
(let loop ((i 0))
(if (< i k)
(begin (vector-set! d (+ n i) (vector-ref s i))
(loop (+ 1 i))))))

(define (restore-vars sv)
(let ((k (vector-length sv)))
(copy-vector! E sv (- (vector-length E) k) k)))

(define (cleanup)
(set! S (cdddr S)))

(define (sub-vector v n k)
(let ((nv (make-vector (- k n))))
(let loop ((i n))
(if (= i k)
nv
(begin (vector-set! nv (- i n) (vector-ref v i))
(loop (+ 1 i)))))))

(define (save-vars fn)
(sub-vector (fun-env fn)
(parm-osize (fun-parms fn))
(parm-nsize (fun-parms fn))))

(define (copy-vars e ks a)
(let loop ((i (car ks))
(a a))
(if (< i n)
(begin (vector-set! e i (car a))
(loop (+ 1 i) (cdr a)))))))

(define (collect-args fp a)
(if (not (parm-var? fp))
a
(let ((k (- (parm-nsize fp) (parm-osize fp))))
(let loop ((n (+ 1 (- (length a) k)))
(a (reverse a))
(v '()))
(cond ((zero? n)
(reverse (cons v a)))
(else
(loop (- n 1)
(cdr a)
(cons (car a) v))))))))

(define (ev-apply x)
(let ((fn (ev (fun x)))
(a  (map ev (args x))))
(let ((a (map box (collect-args (fun-parms fn) a))))
(push (save-vars fn))
(copy-vars (fun-env fn) (fun-parms 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  (map ev (args x))))
(let ((a (map box (collect-args (fun-parms fn) a))))
(cleanup)
(push (save-vars fn))
(copy-vars (fun-env fn) (fun-parms fn) a)
(push E)
(push 'C)
(set! E (fun-env fn))
(ev (fun-term fn)))))

(define (ev-set v x)
(set-car! (vector-ref E (cadr v)) x)
x)

(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)
((eq? '%if f)
((eq? '%set! f)
((eq? '%begin f)
(for-each ev (but-last (cdr x)))
(ev (last x)))
((eq? '%cons f)
((eq? '%car f)
((eq? '%cdr f)