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/interpreter
; 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 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))
            (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) #t))

Interpreter

(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)
    (if (not (null? S))
        (begin (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)))

contact