; -*- lisp-interaction -*- mode, please emacs
;;;; let.el -- Lisplet Evaluator for Teaching
;;; Time-stamp: <2002-02-04 13:33:26 jcgs>
;;;
;;; This is a simple evaluator for lisp and similar languages,
;;; designed for teaching and experimentation about programming
;;; language implementations.
;;;
;;; Copyright (C) 1993 The Harlequin Group.
;;;
;;; This was written as an odd-moments activity by John Sturdy
;;; at Harlequin Ltd (john@harlequin.co.uk); the copyright belongs
;;; to Harlequin. You may pass copies around, so long as you
;;; keep this copyright notice intact.
;;;
;;; It is written to run on GNUemacs, although it should work
;;; on almost any lisp system.

;;;; File 2
;;; Before reading this file, you should have read the file islet.el,
;;; which provides an introduction to lisp sufficient for
;;; understanding this file.

;;;; First, we develop a very simple evaluator, and later do a more
;    sophisticated one.

;   We are going to write a function that behaves like the built-in
;   eval function shown in the previous file. It will take one
;   argument, which can be of any type... so the first thing the
;   function must do is switch on the type of its argument. We'll do
;   this with a cond form, which will distinguish between variables to
;   look up, operator calls to evaluate, numeric constants to pass on,
;   and so forth. And about that variable lookup... we'll need
;   something to look them up in: this is called the environment in
;   programming language parlance. It's possible to have lots of
;   environments for different things, but for now we'll just have one
;   for variables. In the previous file we saw a function for doing
;   lookup; it is assoc, and it works on association lists. To start
;   things off, we'll make an environment pre-loaded with some
;   variables, a (which will contain 1 initially), b (which will
;   contain 2) and so on...

(setq environment '( (a . 1)
		     (b . 2)
		     (c . 4)
		     (d . 8)))

;   Now we can start the evaluator function itself:

(defun naive-eval (arg)
  ;; we decide what to do with the form mostly by looking at its type:
  (cond
   ;; the first few types evaluate to themselves; that is, they are constants:
   ((eq arg nil) arg)
   ((eq arg t) arg)
   ((integerp arg) arg)
   ((stringp arg) arg)
   ;; symbols (variable names) are looked up in the environment
   ((symbolp arg) (let ((pair (assoc arg environment)))
		     (if pair
			 (cdr pair)
		       (error "No such variable in my environment: %s" arg))))
   ;; lists might be a "special form" like "if"; or a function call
   ((listp arg) (let ((operator (car arg))
		       (arguments (cdr arg)))
		   (cond
		    ((eq operator 'quote) (car arguments)) ; unevaled, remember
		    ((eq operator 'if) (if (naive-eval (nth 0 arguments))
					    (naive-eval (nth 1 arguments))
					  (naive-eval (nth 2 arguments))))
		    ;; that's dealt with all the special forms! now do the ones which
		    ;; require all their arguments evaluated:
		    (t			; that means you! ie default case of cond
		     (let ((arguments (mapcar 'naive-eval arguments)))
		       (cond
			((eq operator '+) (+ (nth 0 arguments)
					     (nth 1 arguments)))
			((eq operator '-) (- (nth 0 arguments)
					     (nth 1 arguments)))
			((eq operator '=) (= (nth 0 arguments)
					     (nth 1 arguments)))))))))))

;   That's a very small subset of the language... I've left
;   interesting things like let and setq out; for now I just wanted to
;   show you how simple it is in principle! Try it out on a few things
;   before we go on:

(naive-eval 1)
(naive-eval '(+ 2 3))
(naive-eval '(if (= a 1) 7 b))		; remember a,b,c,d are predefined
					; in the environment

;   Having shown how simple it is in principle, we now go on to do a
;   version with all the special forms defined. We also take a short
;   cut: note how all the operators like +, - above are implemented by
;   calling the corresponding function in the underlying Lisp system;
;   we will just punt straight down a level for those, by using apply.
;   That also lets us pass an arbitrary number of arguments on to them
;   without having to do a loop accumulating the sum for + and so on.
;   We'll just pass on anything I'm not interested in explaining to
;   you at the moment, down to emacs-lisp for it to deal with. The
;   idea is that you should get the idea...

(provide 'let) ; this will be explained later!

;; remove any old definitions first ; this will be explained later!
(mapcar 'makunbound '(languages:lisp-special-forms
		      languages:lisp-procedures
		      eval-context::environment
		      eval-context::language-special-forms
		      eval-context::language
		      eval-context::evaluator))

;;;; environment handling
;   The collection of variables accessible at some point in the
;   program is called the ENVIRONMENT.
;
;   We store the environment in an association list (as described in
;   the previous chapter) in which the variable names are the keys,
;   and the values bound to the names are the values.
;
;   If assoc, which eval::lookup calls, finds no pair (ie no binding)
;   it returns nil; otherwise it returns the value found. This is not
;   quite the semantics we always want, as it does not let us
;   distinguish between nil being bound and there being no binding.
;;; {paragraphs about this to go here}

(defun eval::lookup (key env)
  "Look KEY up in ENV."
  (let* ((vp (assoc key env)))
    (if vp
	(cdr vp)
      nil)))

(defun eval::bind (environment key value)
  "Add to ENVIRONMENT a binding of KEY to VALUE."
  (rplacd environment
	  (cons (cons key
		      value)
		(cdr environment)))
  environment)

(defun eval::update (environment key value)
  "In ENVIRONMENT replace the value bound to KEY by VALUE."
  (let* ((pair (assoc key environment)))
    (if pair
	(rplacd pair value)
      (error "Cannot assign to %s, no existing binding" key)))
  value)

(defun eval::environment-bindings (environment)
  "Return the binding list of ENVIRONMENT."
  (cdr environment))

(defun eval::make-environment (bindings)
  "Make the binding list BINDINGS into an environment."
  (cons 'eval::environment bindings))

(defun eval::new-environment ()
  "Make a new, empty environment."
   (eval::make-environment nil))

;;;; the plain evaluator
;;; {paragraphs about this to go here}

(defun eval:plain-eval (evaluand)
  "Evaluate EVALUAND in the current context, in a plainly lispy manner."
  (cond
   ((or (eq evaluand t) (null evaluand)
	(integerp evaluand)
	(vectorp evaluand)
	(stringp evaluand))
    evaluand)
   ((consp evaluand)
    (let* ((operator-name (car evaluand))
	   (operator-special-form  (eval::lookup
				    operator-name
				    eval-context::language-special-forms))
	   (arglist (cdr evaluand)))
      (if operator-special-form
	  (funcall operator-special-form
		   arglist)
	(let* ((operator-procedure (eval::lookup
				   operator-name
				   eval-context::language)))
	  (if operator-procedure
	      (funcall operator-procedure
		       (mapcar 'eval:eval arglist))
	    (error "%s not defined in current language" operator-name))))))
   ((symbolp evaluand)
    (eval::lookup evaluand eval-context::environment))
   (t (error "No way to evaluate %s" evaluand))))

(defun eval::eval (evaluand)
  "Evaluate EVALUAND in the current context."
  (funcall eval-context::evaluator evaluand))

;;;; operator definition mechanisms
;;; {paragraphs about this to go here}

(defun eval::define-operator-internal (language name args bodyrest)
  "Make an operator definition in a language."
  (eval::bind language name (list 'lambda args bodyrest)))

(defmacro eval::define-operator (language name args &rest body)
  "Sweetener for eval::define-operator-internal."
  (list 'eval::define-operator-internal
	language
	(list 'quote name)
	(list 'quote args)
	(list 'quote (cons 'progn body))))

(defun eval::clone-lisp-procedures (procedure-list)
  "Make evaluator primitives for the lisp operators given in PROCEDURE-LIST."
  (mapcar (function (lambda (procname)
		      (eval::bind languages:lisp-procedures
				  procname
				  (list 'lambda '(arglist)
					(list 'apply (list 'quote procname) 'arglist)))))
	  procedure-list))

;;;; a language to start off with: a simple dialect of Lisp
;;; {paragraphs about this to go here}

(defvar languages:lisp-special-forms (eval::new-environment)
  "The special forms of a lisp-like language for the evaluator.")

(defvar languages:lisp-procedures (eval::new-environment)
  "The procedures of a lisp-like language for the evaluator.")

;;;; useful code for implementing lisp operators:
;;; {paragraphs about this to go here}

(defun eval::add-bindings (new-bindings extant-bindings)
  "Add each binding in NEW-BINDINGS to the alist EXTANT-BINDINGS."
  (if new-bindings
      (let* ((new-binding-pair (car new-bindings)))
	(eval::add-bindings
	 (cdr new-bindings)
	 (cons (cons (car new-binding-pair)
		     (eval::eval (car (cdr new-binding-pair))))
	       extant-bindings)))
    extant-bindings))

(defun eval::eval-forms (forms)
  "Evaluate each of FORMS, returning the value of the last one."
  (if (null forms)
      nil
    (let* ((this-result (eval:eval (car forms)))
	   (remaining-forms (cdr forms)))
      (if (null remaining-forms)
	  this-result
	(eval::eval-forms remaining-forms)))))

(defun eval::cond-internals (cond-body)
  "Recursive evaluator for COND-BODY."
  (if (null cond-body)
      cond-body
    (let* ((this-cond (car cond-body)))
      (if (eval::eval (car this-cond))
	  (eval::eval-forms (cdr this-cond))
	(eval::cond-internals (cdr cond-body))))))

;;;; lisp operator definitions
;;; {paragraphs about this to go here}

;   we make a batch of standard things that simply call the
;   corresponding function in the host lisp system:

(eval::clone-lisp-procedures
 '(cons car cdr
   list assoc rplaca rplacd append reverse nreverse
   + - * / = < >
   or and not
   eq equal
   null integerp vectorp stringp consp symbolp vectorp
   vector make-vector aset aref
   concat
   funcall apply mapcar
   error))

(eval::define-operator
 languages:lisp-special-forms
 let* (let*-body)
 (let* ((binding-list (car let*-body))
	(body-forms (cdr let*-body))
	(eval-context::environment
	 (eval::make-environment
	  (eval::add-bindings 
	   binding-list (eval::environment-bindings
			 eval-context::environment)))))
   (eval::eval-forms body-forms)))

(eval::define-operator
 languages:lisp-special-forms
 if (if-body)
 (let* ((condition (car if-body))
	(cases (cdr if-body))
	(true-case  (car cases))
	(false-case (car (cdr cases))))
   (if (eval::eval condition)
       (eval::eval true-case)
     (eval::eval false-case))))

(eval::define-operator
 languages:lisp-special-forms
 cond (cond-body)
 (eval::cond-internals cond-body))

(eval::define-operator
 languages:lisp-special-forms
 progn (progn-body)
 (eval::eval-forms progn-body))

;;;; initial evaluation environment
;;; {paragraphs about this to go here}

(defvar eval-context::environment (eval::new-environment)
  "The environment of the current context.")

(defvar eval-context::language-special-forms languages:lisp-special-forms
  "The special forms of the language of the current context.")

(defvar eval-context::language languages:lisp-procedures
  "The procedures of the language of the current context.")

(defvar eval-context::evaluator (symbol-function 'eval:plain-eval)
  "The current evaluator.")

;;; {paragraph about loading and running this to go here}

; end of let.el