Outlet meta-circular evaluator

gistfile1.scm

;; Requires Outlet to run: https://github.com/jlongster/outlet
;;
;; Run with: `ol main.ol <input-file>`
;; 
;; This is a meta-circular evaluator for a basic Lisp. It is
;; mostly taken from SICP 4.1*. I wanted to see if I could write a
;; debugger with it. Turns out if I want control over control flow I
;; need a register-based interpreter.
;;
;; * http://mitpress.mit.edu/sicp/full-text/book/book-Z-H-26.html#%_sec_4.1

(require (fs "fs"))

(define src-file (vector-ref __args 0))
(define src (fs.readFileSync src-file "utf-8"))

;; util

(define self-evaluating? literal?)
(define variable? symbol?)

(define (in-list? lst val)
  (cond
   ((null? lst) #f)
   ((eq? (car lst) val) #t)
   (else (in-list? (cdr lst) val))))

;; various forms

(define (text-of-quotation expr)
  (cadr expr))

(define (begin-actions expr)
  (cdr expr))

(define (eval-sequence exprs env)
  (let ((res (%eval (car exprs) env)))
    (if (not (null? (cdr exprs)))
        (eval-sequence (cdr exprs) env)
        res)))

(define (make-lambda args body)
  (cons 'lambda (cons args body)))

(define (definition-variable expr)
  (if (symbol? (cadr expr))
      (cadr expr)
      (caadr expr)))

(define (definition-value expr)
  (if (symbol? (cadr expr))
      (caddr expr)
      (make-lambda (cdadr expr)
              (cddr expr))))

(define (eval-definition expr env)
  (let ((res (%eval (definition-value expr) env)))
    (define-variable! (definition-variable expr) res env)
    res))

(define (eval-assignment expr env)
  (let ((res (%eval (caddr expr) env)))
    (set-variable-value! (cadr expr) res env)
    res))

(define (eval-if expr env)
  (if (%eval (cadr expr) env)
      (%eval (caddr expr) env)
      (let ((rest (cdddr expr)))
        (if (not (null? rest))
            (%eval (car rest) env)
            #f))))

;; procedures

(define (make-procedure args body env)
  (list 'procedure args body env))

(define (compound-procedure? expr)
  (eq? (car expr) 'procedure))

(define procedure-args cadr)
(define procedure-body caddr)
(define (procedure-env proc)
  (car (cdddr proc)))

(define (%apply proc args)
  (cond
   ((primitive-procedure? proc)
    (apply-primitive-procedure proc args))
   ((compound-procedure? proc)
    (eval-sequence (procedure-body proc)
                   (extend-environment
                    (procedure-args proc)
                    args
                    (procedure-env proc))))
   (else (throw "unknown procedure type"))))

;; primitives

(define primitive-procedures
  {:car car
   :cdr cdr
   :cons cons
   :list list
   :null? null?
   :+ (lambda (x y) (+ x y))})

(define (primitive-procedure-names)
  (keys primitive-procedures))

(define (primitive-procedure-objects)
  (map (lambda (el)
         (list 'primitive el))
       (vals primitive-procedures)))

(define (primitive-procedure? proc)
  (eq? (car proc) 'primitive))

(define primitive-implementation cadr)

(define (apply-primitive-procedure proc args)
  (apply (primitive-implementation proc) args))

;; environments

(define (make-frame vars vals)
  (zip vars vals))

(define (extend-environment vars vals base-env)
  (if (== (length vars) (length vals))
      (cons (make-frame vars vals) base-env)
      (if (< (length vars) (length vals))
          (throw "too many arguments supplied")
          (throw "too few arguments supplied"))))

(define enclosing-environment cdr)
(define first-frame car)
(define empty-environment '())

(define (setup-environment)
  (extend-environment
   (primitive-procedure-names)
   (primitive-procedure-objects)
   empty-environment))
(define global-environment (setup-environment))

(define (find-frame-with-var varr env)
  (if (= env empty-environment)
      #f
      (let ((frame (first-frame env)))
        (if (in-list? (keys frame) varr)
            frame
            (find-frame-with-var varr (enclosing-environment env))))))

(define (lookup-variable-value varr env)
  (let ((frame (find-frame-with-var varr env)))
    (if frame
        (dict-ref frame varr)
        (throw (str "unbound variable: " varr)))))

(define (set-variable-value! varr val env)
  (let ((frame (find-frame-with-var varr env)))
    (if frame
        (dict-put! frame varr val)
        (throw (str "unbound variable: " varr)))))

(define (define-variable! varr val env)
  (dict-put! (first-frame env) varr val))

;; predicates

(define (begin? expr)
  (eq? (car expr) 'begin))

(define (assignment? expr)
  (eq? (car expr) 'set!))

(define (quoted? expr)
  (eq? (car expr) 'quote))

(define (definition? expr)
  (eq? (car expr) 'define))

(define (if? expr)
  (eq? (car expr) 'if))

(define (lambda? expr)
  (eq? (car expr) 'lambda))

(define application? list?)

;; eval

(define (%eval src env)
  (let loop ((expr src))
    (cond
     ((self-evaluating? expr) expr)
     ((variable? expr) (lookup-variable-value expr env))
     ((quoted? expr) (text-of-quotation expr))
     ((assignment? expr) (eval-assignment expr env))
     ((definition? expr) (eval-definition expr env))
     ((if? expr) (eval-if expr env))
     ((begin? expr) (eval-sequence (begin-actions expr) env))
     ((lambda? expr) (make-procedure (cadr expr)
                                (cddr expr)
                                env))
     ((application? expr)
      (%apply (%eval (car expr) env)
              (map (lambda (el)
                     (%eval el env))
                   (cdr expr))))
     (else #f))))

(pp (%eval (read src) global-environment))

;; -----------------------------------------------------

;; test.ol

(define (foo x y z)
  (list x y z))

(define (bar lst func)
  (func (car lst) (car (cdr lst))))

(bar (foo 5 6 7) +)

;; output: 11