;;;; -*- Mode: Lisp; Package: CL-USER -*-
;;;; TINY3.lisp
;;;;
;;;; The TINY3 interpreter
;;;;   - A 4-function calculator
;;;;   - User-definable constants
;;;;   - Local bindings
;;;;   - Assignment
;;;;   - User-defined functions
;;;;   - Lexical binding
;;;;   - begin, if, while
;;;;   - Dynamic memory allocation
;;;;
;;;; RDB - 10/04

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;                               Primitives                               ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Wrap a CL boolean function so that it returns $TRUE or $FALSE

(defun make-tiny-boolean-function (fn)
  #'(lambda (&rest args) (if (apply fn args) '$TRUE '$FALSE)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;                            Heap Management                             ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; A cons cell

(defun cons-cell-printer (c stream depth)
  (declare (ignore depth))
  (write-char #\{ stream)
  (loop for x = c then next
        for next = (cons-cell-cdr x)
        while (cons-cell-p next)
        do (format stream "~S, " (cons-cell-car x))
        finally 
        (if (eq next '$NIL)
          (format stream "~S}" (cons-cell-car x))
          (format stream "~S . ~S}" (cons-cell-car x) next))))

(defstruct (cons-cell #|(:print-function cons-cell-printer)|#)
  (car '$NIL) 
  (cdr '$NIL) 
  (free t) 
  (mark nil))


;;; The heap is a vector of cons cells

(defconstant *heap-size* 20)
(defvar *heap* nil)

(defun initialize-heap ()
  (setf *heap*
        (apply #'vector 
               (loop repeat *heap-size* collect (make-cons-cell)))))


;;; Cons cell allocation and deallocation

(defun  allocate-cons (car cdr)
  (let ((i (position t *heap* :key #'cons-cell-free)))
    (when (null i)
      (error "Out of memory!"))
    (let ((c (svref *heap* i)))
      (setf (cons-cell-free c) nil)
      (setf (cons-cell-car c) car)
      (setf (cons-cell-cdr c) cdr)
    c)))

(defun deallocate-cons (c)
  (setf (cons-cell-car c) '$NIL)
  (setf (cons-cell-cdr c) '$NIL)
  (setf (cons-cell-free c) t))


;;; CAR and CDR implementations for TINY

(defun tiny-car (x)
  (if (cons-cell-p x)
    (cons-cell-car x)
    (error "Invalid CONS cell: ~S" x)))

(defun tiny-cdr (x)
  (if (cons-cell-p x)
    (cons-cell-cdr x)
    (error "Invalid CONS cell: ~S" X)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;                              Environments                              ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; A frame is an alist of the form ((VAR1 . VAL1) (VAR2 . VAL2) . . .)
;;; An environment is a list of frames

;;; The global environment consists of a frame containing primitive defs

(defvar *global-environment* 
  (list 
   (list 
    (cons 'cons #'allocate-cons)
    (cons 'car #'tiny-car)
    (cons 'cdr #'tiny-cdr)
    (cons '$NIL '$NIL)
    (cons '+ #'+) 
    (cons '- #'-) 
    (cons '* #'*) 
    (cons '/ #'/)
    (cons '= (make-tiny-boolean-function #'=))
    (cons '< (make-tiny-boolean-function #'<))
    (cons '<= (make-tiny-boolean-function #'<=))
    (cons '> (make-tiny-boolean-function #'>))
    (cons '>= (make-tiny-boolean-function #'>=))
    (cons 'eq (make-tiny-boolean-function #'eq)))))


;;; Lookup the value of VAR in ENV

(defun lookup-variable (var env)
  (if (null env)
    (error "Unbound variable: ~S" var)
    (let ((pair (assoc var (first env))))
      (if (null pair)
        (lookup-variable var (rest env))
        (cdr pair)))))


;;; Define VAR to have the value VALUE in ENV

(defun define-variable (var value env)
  (let ((pair (assoc var (first env))))
    (if (null pair)
      (push (cons var value) (first env))
      (setf (cdr pair) value))
    var))


;;; Return a new environment that extends ENV with an additional frame
;;; containing bindings of VARS to VALS

(defun extend-environment (env vars vals)
  (cons (mapcar #'(lambda (var val) (cons var val)) vars vals) env))


;;; Set the value of VAR in ENV to be VALUE

(defun set-variable-value (var value env)
  (if (null env)
    (error "Nonexistent variable: ~S" var)
    (let ((pair (assoc var (first env))))
      (if (null pair)
        (set-variable-value var value (rest env))
        (setf (cdr pair) value)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;                        Classifying expressions                         ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; The only literal expressions are numbers

(defun literalp (expr)
  (or (numberp expr) (eq expr '$TRUE) (eq expr '$FALSE)))


;;; A variable is any symbol

(defun variablep (expr)
  (symbolp expr))


;;; A binding form is a list of the form (LET vars-and-vals expr)

(defun bindingp (expr)
  (and (consp expr) (eq (first expr) 'let)))


;;; A definition is a list of the form (DEFINE var value)

(defun definitionp (expr)
  (and (consp expr) (eq (first expr) 'define)))


;;; An assignment is a list of the form (SET! var value)

(defun assignmentp (expr)
  (and (consp expr) (eq (first expr) 'set!)))


;;; A sequence is a list of the form (BEGIN expr1 expr2 ...)

(defun sequencep (expr)
  (and (consp expr) (eq (first expr) 'begin)))


;;; A conditional is a list of the form (IF test true-expr false-expr)

(defun conditionalp (expr)
  (and (consp expr) (eq (first expr) 'if)))


;;; An iteration is a list of the form (WHILE test expr)

(defun iterationp (expr)
  (and (consp expr) (eq (first expr) 'while)))


;;; A lambda expression is a list of the form (LAMBDA args body)

(defun lambdap (expr)
  (and (consp expr) (eq (first expr) 'lambda)))


;;; A closure is a list of the form (CLOSURE args body env)

(defun closurep (expr)
  (and (consp expr) (eq (first expr) 'closure)))


;;; A Tiny primitive is just a compiled Common Lisp function

(defun primitivep (expr)
  (functionp expr))


;;; An application is just a list

(defun applicationp (expr)
  (consp expr))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;                            The Interpreter                             ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Return a list of the values of FORMs in ENV

(defun eval-list (forms env)
  (mapcar #'(lambda (f) (teval f env)) forms))


;;; Evaluate a (DEFINE ...) special form

(defun eval-definition (expr env)
  (if (symbolp (second expr))
    (define-variable (second expr) (teval (third expr) env) env)
    (define-variable 
      (first (second expr))
      (teval `(lambda ,(rest (second expr)) ,@(rest (rest expr))) env)
      env)))


;;; Evaluate a (LET ...) special form

(defun eval-binding (expr env)
  (teval `(begin ,@(cddr expr))
         (extend-environment 
          env 
          (mapcar #'first (second expr)) 
          (eval-list (mapcar #'second (second expr)) env))))


;;; Evaluate a (SET! ...) special form

(defun eval-assignment (expr env)
  (set-variable-value (second expr) (teval (third expr) env) env))


;;; Evaluate a (BEGIN ...) special form

(defun eval-sequence (expr env)
  (let (val)
    (dolist (e (rest expr) val)
      (setf val (teval e env)))))


;;; Evaluate an (IF ...) special form

(defun eval-conditional (expr env)
  (if (eq (teval (second expr) env) '$TRUE)
    (teval (third expr) env)
    (if (= (length expr) 4)
      (teval (fourth expr) env)
      '$FALSE)))


;;; Evaluate a (WHILE ...) special form

(defun eval-iteration (expr env)
  (loop while (eq (teval (second expr) env) '$TRUE)
        do (teval (third expr) env)))


;;; Return a closure over LAMBDA-EXPR in ENV

(defun make-closure (lambda-expr env)
  (list 'closure lambda-expr env))


;;; Apply a TINY function to arguments

(defun tapply (fn args)
  (cond ((primitivep fn) (apply fn args))
        ((closurep fn)
         (teval `(begin ,@(cddr (second fn)))
                (extend-environment (third fn) (second (second fn)) args)))
        (t (error "Undefined TINY function: ~S" fn))))


;;; The TINY evaluator

(defun teval (expr env)
  (cond 
   ((literalp expr) expr)
   ((variablep expr) (lookup-variable expr env))
   ((bindingp expr) (eval-binding expr env))
   ((definitionp expr) (eval-definition expr env))
   ((assignmentp expr) (eval-assignment expr env))
   ((sequencep expr) (eval-sequence expr env))
   ((conditionalp expr) (eval-conditional expr env))
   ((iterationp expr) (eval-iteration expr env))
   ((lambdap expr) (make-closure expr env))
   ((applicationp expr) 
    (tapply 
     (teval (first expr) env) 
     (eval-list (rest expr) env)))
   (t (error "Invalid TINY expression: ~S" expr))))
   

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;                           The Top-Level Loop                           ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun tiny ()
  (let ((*print-circle* t))
    (initialize-heap)
    (loop
      (format t "~%>>> ")
      (print (teval (read) *global-environment*)))))