git.fiddlerwoaroof.com
Raw Blame History
(defpackage :fwoar.interp
  (:use :cl )
  (:export ))
(in-package :fwoar.interp)

;; pseudo-scheme

(define-condition not-implemented (error)
  ())
(defun not-implemented (&optional (note ""))
  (error 'not-implemented :note note))

(defstruct true)
(defmethod make-load-form ((o true) &optional environment)
  (declare (ignore environment))
  '(if (boundp true) true (setf true (make-true))))
(defstruct false)
(defmethod make-load-form ((o false) &optional environment)
  (declare (ignore environment))
  '(if (boundp false) false (setf false (make-false))))

(defparameter true
  (if (boundp 'true)
      true
      (make-true)))
(defparameter false
  (if (boundp 'false)
      false
      (make-false)))

(defmacro define (what &body body)
  (etypecase what
    (cons (destructuring-bind (name . args) what
            `(progn (defun ,name ,args
                      ,@body)
                    (defparameter ,name ',name))))
    (symbol `(defparameter ,what
               (progn ,@body)))))

(define (symbol? v) (symbolp v))
(define (string? v) (stringp v))
(define (number? v) (numberp v))
(define (char? v) (characterp v))
(define (boolean? v) (member v (list true false)))
(define (vector? v) (vectorp v))
(define (atom? v) (not (consp v)))
(define (pair? v) (consp v))
(define (null? v) (null v))
(define (procedure? v) (or (symbol? v)
                           (functionp v)))
(define (eq? a b) (eql a b))
(define (set-cdr! pair value) (setf (cdr pair) value))

(defmacro set! (thing val)
  `(setq ,thing ,val))



;; Environments
(define (lookup id env)
  (if (pair? env)
      (if (eq? (caar env) id)
          (cdar env)
          (lookup id (cdr env)))
      (error "No such binding ~s" id)))
(define (update! id env value)
  (if (pair? env)
      (if (eq? (caar env) id)
          (progn (set-cdr! (car env) value)
                 value)
          (update! id (cdr env) value))
      (error "No such binding ~s" id)))
(define (extend env variables values)
  (cond ((pair? variables)
         (if (pair? values)
             (cons (cons (car variables)
                         (car values))
                   (extend env
                           (cdr variables)
                           (cdr values)))
             (error "Too few values")))
        ((null? variables)
         (if (null? values)
             env
             (error "Too many values")))
        ((symbol? variables) (cons (cons variables values) env))))

(define env.init '())
(defmacro definitial (name &optional (value nil value-p))
  (if value-p
      `(progn (set! env.global (acons ',name ,value
                                      env.global))
              ',name)
      `(progn (set! env.global (acons ',name 'void
                                      env.global))
              ',name)))

(defmacro defprimitive (name value arity)
  (alexandria:with-gensyms (values)
    `(definitial ,name
         (lambda (,values)
           (if (= ,arity (length ,values))
               (apply ,value ,values)
               (error "Incorrect arity: ~s ~s" ',name ,values))))))

(defun embedded< (a b)
  (or (< a b)
      false))

(progn (define env.global env.init)

       (definitial t true)
       (definitial f false)
       (definitial nil ())

       (definitial apply
           (lambda (values)
             (invoke (car values)
                     (cadr values))))

       (definitial foo)
       (definitial bar)
       (definitial fib)
       (definitial fact)

       (defprimitive cons #'cons 2)
       (defprimitive car #'car 1)
       (defprimitive cdr #'cdr 1)
       (defprimitive set-cdr! 'set-cdr! 2)
       (defprimitive + #'+ 2)
       (defprimitive eq? 'eq? 2)
       (defprimitive < 'embedded< 2))



;; Functions
(define (invoke fn args)
  (if (procedure? fn)
      (funcall fn args)
      (error "Not a function ~s" fn)))
(define (make-function variables body env)
  (lambda (values)
    (eprogn body
            (extend env variables values))))



;; Interpreter
(define empty-begin 813)
(define (eprogn exps env)
  (if (pair? exps)
      (if (pair? (cdr exps))
          (progn (evaluate (car exps) env)
                 (eprogn (cdr exps) env))
          (evaluate (car exps) env))
      empty-begin))

(define (evlis exps env)
  (if (pair? exps)
      (cons (evaluate (car exps) env)
            (evlis (cdr exps) env))
      '()))

(let ((*eval-depth* 0))
  (declare (special *eval-depth*))
  (define (evaluate e env)
    (let ((*eval-depth* (if (boundp '*eval-depth*)
                            (1+ *eval-depth*)
                            0)))
      (declare (special *eval-depth*))
      (if (atom? e)
          (cond
            ((symbol? e) (lookup e env))
            ((or (number? e)
                 (string? e)
                 (char? e)
                 (boolean? e)
                 (vector? e))
             e)
            (t (error "cannot evaluate ~s" e)))
          (case (car e)
            (quote (cadr e))
            (if (if (not (false-p (evaluate (cadr e) env)))
                    (evaluate (caddr e) env)
                    (evaluate (cadddr e) env)))
            (begin (eprogn (cdr e) env))
            (set! (update! (cadr e) env
                           (evaluate (caddr e) env)))
            (lambda (make-function (cadr e) (cddr e) env))
            (t
             (let ((function (evaluate (car e) env))
                   (args (evlis (cdr e) env)))
               (format t "~&~a=> (~s ~{~s~^ ~})~%"
                       (fill (make-string (* 2 *eval-depth*))
                             #\space)
                       (car e) args)
               (let ((result (invoke function args)))
                 (format t "~&~a<= ~s~%"
                         (fill (make-string (* 2 *eval-depth*))
                               #\space)
                         result)
                 result))))))))

(define (chapter1-scheme)
  (labels ((toplevel ()
             (let* ((*package* (find-package :fwoar.interp))
                    (exp (read)))
               (unless (equal exp '(end))
                 (format t "~&~s~%"
                         (evaluate exp env.global))
                 (toplevel)))))
    (toplevel)))