Scheme3 Source Code

From the book Compiling Lambda Calculus

Provided under the Creative Commons Zero (CC0) licence

You might prefer to download the source code archive

; 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/

(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 prim-narg caddr)

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

Stage 1

(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))
            (let ((a (flatten (cadr x))))
              `(lambda (,n
                        ,(+ n (length a))
                        ,(not (list? (cadr x))))
                       ,@(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)
            `(%quote ,(cadr x)))
          ((eq? 'lambda (car x))
            (assert-args! x 2 #t)
            `(%lambda ,(cadr x)
                      ,(if (null? (cdddr x))
                           (comp-expr (caddr x) #t)
                           (comp-expr (cons 'begin (cddr x))
                                      #t))))
          ((eq? '%ref (car x))
            x)
          ((eq? 'if (car x))
            (assert-args! x 3 #f)
            `(%if ,(comp-expr (cadr x) #f)
                  ,(comp-expr (caddr x) t)
                  ,(comp-expr (cadddr x) t)))
          ((eq? 'set! (car x))
            (assert-args! x 2 #f)
            `(%set! ,(cadr x) ,(comp-expr (caddr x) #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) #t))

Stage 2

(define (stage2 x)

  (define fp-osize car)
  (define fp-nsize cadr)
  (define fp-var?  caddr)

  (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)
    (let ((osize  (fp-osize (cadr x)))
          (nsize  (fp-nsize (cadr x)))
          (funlab (newlabel))
          (endlab (newlabel)))
      (emit `(%%jump ,endlab))
      (emit `(%%label ,funlab))
      (if (fp-var? (cadr x))
          (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)))))
      (comp-s2 (caddr x))
      (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))))
      (comp-s2 (cadr x))
      (emit (if t `(%%tail-apply ,k) `(%%apply ,k)))
      (emit `(%%label ,k))))

  (define (comp-ref x)
    (emit `(%%ref ,(cadr x))))

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

  (define (comp-if x)
    (let ((tlab (newlabel))
          (flab (newlabel)))
      (comp-s2 (cadr x))
      (emit `(%%jump-false ,flab))
      (comp-s2 (caddr x))
      (emit `(%%jump ,tlab))
      (emit `(%%label ,flab))
      (comp-s2 (cadddr x))
      (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)
    (comp-s2 (caddr x))
    (let ((loc (cadr x)))
      (emit `(%%set-ref! ,(cadr loc)))))

  (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 prim-ops (map cadr primitives))

  (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

(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]) != ")
              (emit (cadr x) ") err1();"))
            ((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)
              (emit "collect_args(" (cadr x) ");"))
            ((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)
              (emit "pushfun(" (cadr x)
                    ", " (caddr x)
                    ", " (cadddr x) ");"))
            ((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)
              (emit "push(vector(L)[" (cadr x) "]);"))
            ((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)
              (emit "push(unbox(vector(E)[" (cadr x) "]));"))
            ((eq? op '%%return)
              (emit "K = ret(); break;"))
            ((eq? op '%%save-vars)
              (emit "save_vars(" (cadr x) ", " (caddr x) ");"))
            ((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)
              (emit "pushval(" (cadr x) ");"))
            (else
              (lc-error "bad opcode" x)))))

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

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

Runtime Support

/*
 * 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);
}

cell readexp(void) {
	#define B 256
	char	b[B];
	int	i;
	cell	n, a, p;

	while (isspace(*I))
		I++;
	if ('(' == *I) {
		I++;
		a = NIL;
		n = readexp();
		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;
			n = readexp();
		}
		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)) {
		printf("#<function %d>", (int) cadr(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;
	n = readexp();
	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);
}

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;
		if (P-m > 0) {
			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);
			return cadr(T);
		}
	}
	push(E);
	pushval(k);
	E = cddr(T);
	return cadr(T);
}

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 ret(void) {
	int	k, n;

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

contact