LiSP Ch. 1

gistfile1.scm

;; outlet: https://github.com/jlongster/outlet

(define-macro (case c . variants)
  `(cond
    ,@(map (lambda (exp)
             (if (== (car exp) 'else)
                 exp
                 `((list-find ',(car exp) ,c)
                   ,@(cdr exp))))
           variants)))

(define (atom? exp)
  (or (number? exp)
      (string? exp)
      (boolean? exp)
      (null? exp)
      (symbol? exp)))

(define (eprogn exps env)
  (if (list? exps)
      (if (list? (cdr exps))
          (begin
            (evaluate (car exps) env)
            (eprogn (cdr exps) env))
          (evaluate (car exps) env))
      '()))

(define (lookup var env)
  (let ((v (dict-ref env var)))
    (if (== v undefined)
        (throw (str "lookup: no such binding: " var))
        v)))

(define (update! id env value)
  (if (== (dict-ref env id) undefined)
      (throw (str "update!: no such binding: " id)))
  (dict-put! env id value))

(define (evlis exps env)
  (map (lambda (exp)
         (evaluate exp env))
       exps))

(define empty-env '())
(define global-env '())

(define-macro (define-initial name val)
  `(dict-put! global-env ',name ,val))

(define-macro (define-primitive name val arity)
  `(define-initial ,name
     (lambda (vals)
       (if (= ,arity (length vals))
           (apply ,val vals)
           (throw (str "wrong number of arguments"))))))

(define-initial t #t)
(define-initial f #f)
(define-initial nil '())

(define-primitive cons cons 2)
(define-primitive car car 1)
(define-primitive + (lambda (x y) (+ x y)) 2)
(define-primitive < (lambda (x y) (< x y)) 2)

(define (extend-env env vars vals)
  (dict-merge env (zip vars vals)))

(define (invoke fn args env)
  (if (function? fn)
      (fn args env)
      (throw (str "not a function: " fn))))

(define (make-function vars body env)
  (lambda (vals)
    (eprogn body (extend-env env vars vals))))

(define (evaluate exp env)
  (if (atom? exp)
      (if (symbol? exp)
          (lookup exp env)
          exp)
      (case (car exp)
        ((quote) (cadr exp))
        ((if) (if (evaluate (cadr exp) env)
                  (evaluate (caddr exp) env)
                  (evaluate (car (cdddr exp)) env)))
        ((begin) (eprogn (cdr exp) env))
        ((set!) (update! (cadr exp)
                         env
                         (evaluate (caddr exp) env)))
        ((lambda) (make-function (cadr exp) (cddr exp) env))
        (else (invoke (evaluate (car exp) env)
                      (evlis (cdr exp) env)
                      env)))))

(define prog
  '((lambda (x y)
      (+ x y))
    1 2))

(define (start)
  (println (evaluate prog global-env)))

(start)