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, classic model
; 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 0)

Compiler

(define (comp x)

  (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? 'if (car x))
            `(%if ,(comp-expr (cadr x) #f)
                  ,(comp-expr (caddr x) t)
                  ,(comp-expr (cadddr x) t)))
          (else
            `(,(if t '%tail-apply '%apply)
              ,@(map (lambda (x)
                       (comp-expr x #f))
                     x)))))
  
  (comp-expr x #f))

Interpreter / Abstract Machine

(define (eval x)

  (define E
    '((cons  . %cons)
      (car   . %car)
      (cdr   . %cdr)
      (pair? . %pair?)
      (null? . %null?)))
  
  (define S '())

  (define (bind v a e)
    (cons (cons v a) e))

  (define (make-fun x)
    `(%fn ,E ,(cadr x) ,(caddr x)))

  (define fun-env  cadr)
  (define fun-var  caaddr)
  (define fun-term cadddr)

  (define fun cadr)
  (define arg caddr)

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

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

  (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))))
            (push E)
            (push 'C)
            (set! E (bind (fun-var fn) a (fun-env fn)))
            (let ((n (ev (fun-term fn))))
              (cleanup)
              n)))))

  (define (ev-tail-apply x)
    (let ((fn (ev (fun x))))
      (if (primitive? fn)
          (ev-apply-prim fn (cddr x))
          (let ((a (ev (arg x))))
            (cleanup)
            (push E)
            (push 'C)
            (set! E (bind (fun-var fn) a (fun-env fn)))
            (ev (fun-term fn))))))

  (define (ev x)
    (if (symbol? x)
        (cdr (assq x E))
        (let ((f (car x)))
          (cond ((eq? '%lambda f)
                  (make-fun x))
                ((eq? '%apply f)
                  (ev-apply x))
                ((eq? '%tail-apply f)
                  (ev-tail-apply x))
                ((eq? '%quote f)
                  (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