Scheme₀ 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_0 compiler/interpreter with environment propagation
; 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 1)

Compiler

(define (comp x)

  (define (bind x e n)
    (cons (cons x n) e))

  (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 ,(cconv (caddr x)
                                (bind (caadr x) e n)
                                (+ 1 n))))
          (else
            (cons (cconv (car x) e n)
                  (cconv (cdr x) e n)))))

  (define primitives
    '((cons  . 0)
      (car   . 1)
      (cdr   . 2)
      (pair? . 3)
      (null? . 4)))
  
  (define (closure-conv x)
    (cconv x '() (length primitives)))

  (define (comp-expr x t)
    (cond ((not (pair? x))
            x)
          ((eq? 'quote (car x))
            `(%quote ,(cadr x)))
          ((eq? 'lambda (car x))
            `(%lambda ,(cadr x)
                      ,(comp-expr (caddr 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)))
          ((assq (car x) primitives)
            => (lambda (i)
                 `(%apply (%ref ,(cdr 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 '#(%cons %car %cdr %pair? %null?))
  (define S '())

  (define (extend-vector k e)
    (let ((v (make-vector (+ 1 k))))
      (let loop ((i 0))
        (if (= i k)
            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-slot cadr)
  (define fun-env  caddr)
  (define fun-term cadddr)

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

  (define (cleanup)
    (set! E (cadr S))
    (set! S (cddr S)))

  (define fun cadr)
  (define arg caddr)

  (define *primitives*
    '(%cons
      %car
      %cdr
      %pair?
      %null?))
  
  (define (primitive? x)
    (and (memq x *primitives*) #t))

  (define (ev-apply-prim fn a)
    (cond ((eq? '%cons fn)
            (cons (ev (car a)) (ev (cadr a))))
          ((eq? '%car fn)
            (car (ev (car a))))
          ((eq? '%cdr fn)
            (cdr (ev (car a))))
          ((eq? '%pair? fn)
            (if (pair? (ev (car a))) 't '()))
          (else ; %null?
            (if (null? (ev (car a))) 't '()))))

  (define (ev-apply x)
    (let ((fn (ev (fun x))))
      (if (primitive? fn)
          (ev-apply-prim fn (cddr x))
          (let ((a (ev (arg x))))
            (vector-set! (fun-env fn)
                         (fun-slot 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  (ev (arg x))))
      (vector-set! (fun-env fn) (fun-slot fn) a)
      (cleanup)
      (push E)
      (push 'C)
      (set! E (fun-env fn))
      (ev (fun-term fn))))

  (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)
              (vector-ref E (cadr x)))
            ((eq? '%if f)
              (if (null? (ev (cadr x)))
                  (ev (cadddr x))
                  (ev (caddr x))))
            (else
              (error "lc: cannot eval" x)))))

  (ev x))

(define (evcomp x)
  (eval (comp x)))

contact  |  privacy