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/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)))
(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)) (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 prim-op cadr) (define prim-narg caddr) (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)) `(%quote ,(cadr x))) ((eq? 'lambda (car x)) `(%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)) `(%if ,(comp-expr (cadr x) #f) ,(comp-expr (caddr x) t) ,(comp-expr (cadddr x) t))) ((eq? 'set! (car x)) `(%set! ,(cadr x) ,(comp-expr (caddr x) #f))) ((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))
(define (eval x) (define E '#()) (define S '()) (define (extend-vector ks e) (let ((v (make-vector (cadr ks))) (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) `(%fn ,(cadr x) ,(extend-vector (cadr x) E) ,(caddr x))) (define fun-parms cadr) (define parm-osize car) (define parm-nsize cadr) (define parm-var? caddr) (define fun-env caddr) (define fun-term cadddr) (define (push x) (set! S (cons x S))) (define fun cadr) (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) (restore-vars (caddr S)) (set! E (cadr S)) (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 ((n (cadr ks))) (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) (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) (unbox (vector-ref E (cadr x)))) ((eq? '%if f) (if (null? (ev (cadr x))) (ev (cadddr x)) (ev (caddr x)))) ((eq? '%set! f) (ev-set (cadr x) (ev (caddr x)))) ((eq? '%begin f) (for-each ev (but-last (cdr x))) (ev (last x))) ((eq? '%cons f) (cons (ev (cadr x)) (ev (caddr x)))) ((eq? '%car f) (car (ev (cadr x)))) ((eq? '%cdr f) (cdr (ev (cadr x)))) ((eq? '%pair? f) (if (pair? (ev (cadr x))) 't '())) ((eq? '%null? f) (if (null? (ev (cadr x))) 't '())) (else (error "lc: cannot eval" x))))) (ev x)) (define (evcomp x) (eval (comp x)))