# Scheme3 Source Code

From the book Compiling Lambda Calculus

Provided under the Creative Commons Zero (CC0) licence

```; Scheme_3 compiler with C code back-end
; By Nils M Holm, 2016
;
; 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/

; Example: (with-output-to-file "tmp.c"
;            (lambda ()
;              (comp '(((lambda (x) (lambda (y) (cons x y))) 'x) 'y))))
;
;          ;; And then: cc -o tmp tmp.c s9core.c && ./tmp

(define version 8)

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

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

(define (lc-error m . a)
(apply error (string-append "lc: " m) a))```

## Compiler

```(define prim-op   cadr)
(define prim-args cddr)

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

### Stage 1 - Closure Conversion

```(define (stage1 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 (assert-args! x n v)
(let ((k (length (cdr x))))
(cond ((= k n))
((and (> k n) v))
(else (lc-error "wrong argument count" x)))))

(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)
((symbol? x)
(lc-error "undefined" x))
((not (pair? x))
x)
((eq? 'quote (car x))
(assert-args! x 1 #f)
((eq? 'lambda (car x))
(assert-args! x 2 #t)
,(if (null? (cdddr x))
(comp-expr (cons 'begin (cddr x))
#t))))
((eq? '%ref (car x))
x)
((eq? 'if (car x))
(assert-args! x 3 #f)
((eq? 'set! (car x))
(assert-args! x 2 #f)
((eq? 'begin (car x))
(assert-args! x 1 #t)
`(%begin ,@(map (lambda (x)
(comp-expr x #f))
(but-last (cdr x)))
,(comp-expr (last x) t)))
((assq (car x) primitives)
=> (lambda (i)
(apply assert-args! x (prim-args 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))```

### Stage 2 - Abstract Code Generation

```(define (stage2 x)

(define fp-osize car)

(define Prog '())
(define Lab  0)

(define Lit (reverse '(() t)))
(define Nlit 1)

(define (newlabel)
(set! Lab (+ 1 Lab))
Lab)

(define (newlit)
(set! Nlit (+ 1 Nlit))
Nlit)

(define (emit x)
(set! Prog (cons x Prog)))

(define (comp-lambda x)
(funlab (newlabel))
(endlab (newlabel)))
(emit `(%%jump ,endlab))
(emit `(%%label ,funlab))
(emit `(%%collect-args ,(- nsize osize))))
(emit `(%%save-vars ,osize ,nsize))
(emit `(%%assert-args ,(- nsize osize)))
(let loop ((i 0))
(if (< i (- nsize osize))
(begin (emit `(%%setup-env ,i ,(- nsize i 1)))
(loop (+ 1 i)))))
(emit `(%%return))
(emit `(%%label ,endlab))
(emit `(%%fun ,funlab ,osize ,nsize))))

(define (comp-apply x t)
(let ((k (newlabel)))
(for-each comp-s2 (cddr x))
(emit `(%%val ,(length (cddr x))))
(emit (if t `(%%tail-apply ,k) `(%%apply ,k)))
(emit `(%%label ,k))))

(define (comp-ref x)

(define (comp-quote x)
(emit '(%%lit 0))
(begin (set! Lit (cons (cadr x) Lit))
(emit `(%%lit ,(newlit))))))

(define (comp-if x)
(let ((tlab (newlabel))
(flab (newlabel)))
(emit `(%%jump-false ,flab))
(emit `(%%jump ,tlab))
(emit `(%%label ,flab))
(emit `(%%label ,tlab))))

(define (comp-begin x)
(let loop ((x (cdr x)))
(cond ((null? (cdr x))
(comp-s2 (car x)))
(else
(comp-s2 (car x))
(emit '(%%drop))
(loop (cdr x))))))

(define (comp-set x)

(define (comp-prim x p)
(for-each comp-s2 (cdr x))
(emit (cond ((eq? '%cons  p) '(%%cons))
((eq? '%car   p) '(%%car))
((eq? '%cdr   p) '(%%cdr))
((eq? '%pair? p) '(%%pair?))
((eq? '%null? p) '(%%null?)))))

(define (comp-s2 x)
(cond ((eq? '%lambda (car x)) (comp-lambda x))
((eq? '%apply (car x)) (comp-apply x #f))
((eq? '%tail-apply (car x)) (comp-apply x #t))
((eq? '%ref (car x)) (comp-ref x))
((eq? '%quote (car x)) (comp-quote x))
((eq? '%if (car x)) (comp-if x))
((eq? '%set! (car x)) (comp-set x))
((eq? '%begin (car x)) (comp-begin x))
((memq (car x) prim-ops)
=> (lambda (i)
(comp-prim x (car i))))
(else (error "unknown op in stage2" x))))

(comp-s2 x)
(emit '(%%halt))
(cons (cons '%%litpool (reverse Lit))
(reverse Prog)))```

### Stage 3 - C Code Generation

```(define (stage3 x)

(define (emit* . x)
(for-each display x))

(define (emit . x)
(apply emit* x)
(newline))

(define (comp x)
(let ((op (car x)))
(cond ((eq? op '%%apply)
(emit "K = apply(" (cadr x) ", 0); break;"))
((eq? op '%%assert-args)
(emit* "if ((int) car(vector(S)[P-4]) != ")
((eq? op '%%car)
(emit "vector(S)[P-1] = car(vector(S)[P-1]);"))
((eq? op '%%cdr)
(emit "vector(S)[P-1] = cdr(vector(S)[P-1]);"))
((eq? op '%%collect-args)
((eq? op '%%cons)
(emit* "vector(S)[P-2] = cons(vector(S)[P-2],")
(emit " vector(S)[P-1]); P--;"))
((eq? op '%%drop)
(emit "P--;"))
((eq? op '%%fun)
((eq? op '%%halt)
(emit "printexp(pop());")
(emit "exit(0);"))
((eq? op '%%jump)
(emit "K = " (cadr x) "; break;"))
((eq? op '%%jump-false)
(emit "if (pop() == NIL) { K = " (cadr x) "; break; }"))
((eq? op '%%label)
(emit "case " (cadr x) ":"))
((eq? op '%%lit)
((eq? op '%%litpool)
(emit "L = mklitpool(\"" (cdr x) "\");")
(emit "for (K = 0;;) switch (K) {")
(emit "case 0:"))
((eq? op '%%null?)
(emit* "vector(S)[P-1] = NIL == vector(S)[P-1]?")
(emit "vector(L)[1]: NIL;"))
((eq? op '%%pair?)
(emit* "vector(S)[P-1] = pair_p(vector(S)[P-1])?")
(emit "vector(L)[1]: NIL;"))
((eq? op '%%ref)
((eq? op '%%return)
(emit "K = ret(); break;"))
((eq? op '%%save-vars)
((eq? op '%%set-ref!)
(emit "car(vector(E)[" (cadr x) "]) = vector(S)[P-1];"))
((eq? op '%%setup-env)
(emit* "T = box(vector(S)[P" (- -5 (cadr x)) "]); ")
(emit "vector(E)[" (caddr x) "] = T;"))
((eq? op '%%tail-apply)
(emit "K = apply(" (cadr x) ", 1); break;"))
((eq? op '%%val)
(else

(emit "#include \"scm8.c\"")
(emit "int main(void) {")
(emit "init();")
(for-each comp x)
(emit "}}"))

(define (comp x)
(stage3 (stage2 (stage1 x))))
```

## Runtime Support Module

```/*
* Scheme_3 compiler runtime
* By Nils M Holm, 2016
*
* 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/
*/

#include "s9core.h"
#include "s9import.h"

#define	SEG	1000

#define box(x)	cons((x),NIL)
#define unbox	car

cell	E, L, S, T;
int	K, P, Z;
char	*I;

cell	*R[] = { &E, &L, &S, &T, NULL };

void err(char *s) {
fprintf(stderr, "LC8 error: %s\n", s);
exit(1);
}

void err1(void) {
err("wrong number of arguments");
}

void init(void) {
s9_init(R);
P = 0;
Z = SEG;
S = make_vector(Z);
}

#define B 256
char	b[B];
int	i;
cell	n, a, p;

while (isspace(*I))
I++;
if ('(' == *I) {
I++;
a = NIL;
while (n != VOID) {
if (NIL == a) {
save(a = cons(NIL, NIL));
}
else {
p = cons(NIL, NIL);
cdr(a) = p;
a = cdr(a);
}
car(a) = n;
}
if (NIL == a)
return NIL;
return unsave(1);
}
else if (')' == *I) {
I++;
return VOID;
}
else {
for (i = 0; !isspace(*I) && ')' != *I; i++) {
b[i] = *I++;
if (i >= B) err("symbol too long");
}
b[i] = 0;
return symbol_ref(b);
}
}

void px(cell x) {
if (function_p(x)) {
}
else if (symbol_p(x)) {
printf("%s", symbol_name(x));
}
else if (NIL == x) {
printf("()");
}
else {
putchar('(');
while (!atom_p(x)) {
px(car(x));
x = cdr(x);
if (pair_p(x))
putchar(' ');
}
if (x != NIL) {
printf(" . ");
px(x);
}
putchar(')');
}
}

void printexp(cell x) {
px(x);
putchar('\n');
}

cell mklitpool(char *s) {
cell	n, v, *vv;
int	i;

I = s;
save(n);
v = make_vector(length(n));
unsave(1);
vv = vector(v);
for (i = 0; n != NIL; n = cdr(n))
vv[i++] = car(n);
return v;
}

void push(cell x) {
cell	v;

if (P >= Z) {
T = x;
v = make_vector(Z+SEG);
memcpy(vector(v), vector(S), Z*sizeof(cell));
Z += SEG;
S = v;
}
vector(S)[P++] = x;
}

cell pop(void) {
if (P < 0)
err("stack underflow");
return vector(S)[--P];
}

void pushval(int n) {
push(new_atom(n, NIL));
}

int popval(void) {
return car(pop());
}

void pushfun(int k, int n, int z) {
cell	fn, ne;

ne = make_vector(z);
memcpy(vector(ne), vector(E), n*sizeof(cell));
fn = new_atom(k, ne);
push(new_atom(T_FUNCTION, fn));
}

void collect_args(int na) {
cell	k, e, va;
int	n, i;

k = vector(S)[P-1];
e = vector(S)[P-2];
n = car(vector(S)[P-3]);
if (n < na-1)
err1();
save(va = NIL);
for (i = 0; n-i >= na; i++) {
va = cons(vector(S)[P-4-i], va);
car(Stack) = va;
}
va = unsave(1);
P = P-i+1;
vector(S)[P-1] = k;
vector(S)[P-2] = e;
vector(S)[P-4] = va; /* save va first! */
vector(S)[P-3] = box(na);
}

void save_vars(int n, int k) {
cell	v;
int	i;

v = make_vector(k-n);
for (i=n; i<k; i++)
vector(v)[i-n] = vector(E)[i];
push(v);
}

void restore_vars(cell v) {
int	kv, ke, i;

kv = vector_len(v);
ke = vector_len(E);
for (i=0; i<kv; i++)
vector(E)[ke-kv+i] = vector(v)[i];
}

int apply(int k, int tco) {
int	m, n;
cell	e, kk;

T = pop();
if (!function_p(T))
err("application of non-function");
if (tco) {
m = unbox(vector(S)[P-1])+1;
restore_vars(vector(S)[P-3]);
kk = vector(S)[P-m-2];
e = vector(S)[P-m-3];
n = unbox(vector(S)[P-m-4])+1;
memcpy(&vector(S)[P-m-n-3],
&vector(S)[P-m],
m*sizeof(cell));
P -= n+1;
vector(S)[P-1] = kk;
vector(S)[P-2] = e;
E = cddr(T);
}
push(E);
pushval(k);
E = cddr(T);
}

int ret(void) {
int	k, n;

T = pop();
restore_vars(pop());
k = popval();
E = pop();
n = popval();
P -= n;
push(T);
return k;
}
```