;;;; Meta-Lisp: An Evaluator Prototype
;;;;
;;;; File:	meta-lisp.lsp
;;;; Author:	course
;;;; Version:	9

;; LISP is a very good language for writing prototypes.
;; This is a `rapid prototype' of the LISP51 evaluator
;; component.

(defvar *environment*)
;; Our one and only global, which we must declare before
;; first use.



;; Memory Model:
;;
;; We want to implement the LISP memory model for use by
;; our prototype.  Since we are NOT prototyping the
;; memory system, we want a cheap implementation.
;; Therefore:
;;
;;   C++ Type/Function		Is Modeled By
;;
;;   cons			cons-cell
;;   make_cons			cons
;;   car			car
;;   cdr			cdr
;;   symbol			symbol
;;   read			read
;;   princ			princ
;;   symbol_value (S)		(m-symbol-value 'S)
;;   set_symbol_value (S,V)	(m-set-symbol-value
;;                                'S 'V)
;;   symbol_function (S)	(m-symbol-function 'S)
;;   set_symbol_function (S,V)	(m-set-symbol-function
;;                                'S 'V)
;;   NULL			'm-unbound
;;   unboundp			(eql 'm-unbound ...)
;;   S1 == S2                   (eql 'S1 'S2)
;;   fixnum			integer
;;   non-special function	(m-primitive . f)
;;   special function		(m-special . f)
;;
;;	where S, S1, S2 are symbols,
;;            V is an s-expression;
;;            f is a #'(lambda ...) that can be called
;;	           as in (funcall f argument-list).


(defun m-symbol-value (s)
  (get s 'm-value 'm-unbound))

(defun m-set-symbol-value (s v)
  (setf (get s 'm-value) v))

(defun m-symbol-function (s)
  (get s 'm-function 'm-unbound))

(defun m-set-symbol-function (s v)
  (setf (get s 'm-function) v))

(defun m-unboundp (x)
  (eql 'm-unbound x))

;; We need to be able to reinitialize our symbol table
;; after we have been previously running.
;;
(defun m-initialize-symbol-table ()

  ;; Get rid of all previous 'm-value and 'm-function
  ;; properties.
  ;;
  (do-symbols (sym)
	      (remprop sym 'm-value)
	      (remprop sym 'm-function))
  (dolist (pkg (package-use-list *package*))
	  (do-symbols (sym pkg)
		      (remprop sym 'm-value)
		      (remprop sym 'm-function)))

  (m-set-symbol-value 't 't)
  (m-set-symbol-value 'nil 'nil)

  (m-initialize-primitive-functions))



;; We need to be able to set the symbol-function
;; components of the symbol table for the primitive
;; functions that will be implemented in C++.

;; For example, if LIST were a primitive function, we
;; would need to do:
;;
;;	(m-set-symbol-function 'list
;;	 (cons 'm-primitive
;;	       #'(lambda (args) args)))
;;
;; The primitives are coded to take a single argument
;; args which is the list of actual argument values; and
;; to return the value that is to be returned when the
;; LISP function being implemented is executed on these
;; actual argument values.  Thus a primitive for LIST
;; would be rather simple: it just returns args.
;;
;; Two more examples:
;;
;;	(m-set-symbol-function 'set
;;	 (cons 'm-primitive
;;	       #'(lambda (args)
;;		  (m-set-symbol-value (first args)
;;				      (second args)))))
;;
;;	(m-set-symbol-function 'quote
;;	 (cons 'm-special
;;	       #'(lambda (args) (first args))))
;;
;; M-specials and m-primitives are alike (they are both
;; implemented in C++ by `function's), but m-primitives
;; are given evaluated actual arguments and m-specials
;; are given unevaluated actual arguments.



;; The following are helpers to set up the initial
;; symbol table symbol-function components.

(defmacro m-defprim (name arglist &rest body)
  `(m-set-symbol-function
    ',name
    (cons 'm-primitive #'(lambda ,arglist . ,body))))

(defmacro m-defspec (name arglist &rest body)
  `(m-set-symbol-function
    ',name
    (cons 'm-special #'(lambda ,arglist . ,body))))


;; In what follows, some of the primitives may forward
;; reference to functions we have not defined yet, and
;; will be hard to understand until you have read
;; further.

;; Not every LISP51 primitive is implemented.  Missing
;; are:
;;
;;	symbol-plist		primitive-functionp
;;	set-symbol-plist	special-primitivep
;;	run			gc
;;	gc-limit		set-gc-limit



(defun m-initialize-primitive-functions ()

  ;; Arithmetic Functions
  
  (m-defprim + (args)
   (apply #'+ args))
  
  (m-defprim - (args)
   (apply #'- args))
  
  (m-defprim * (args)
   (apply #'* args))
  
  (m-defprim floor (args)
   (apply #'floor args))
  
  (m-defprim mod (args)
   (apply #'mod args))
  
  (m-defprim expt (args)
   (apply #'expt args))
  
  (m-defprim random (args)
   (apply #'random args))
  
  (m-defprim = (args)
   (apply #'= args))
  
  (m-defprim < (args)
   (apply #'< args))


  ;; List manipulating functions
  
  (m-defprim car (args)
   (car (first args)))
  
  (m-defprim cdr (args)
   (cdr (first args)))
  
  (m-defprim cons (args)
   (cons (first args) (second args)))


  ;; Symbol Primitives

  (m-defprim symbol-value (args)
   (let ((result (m-symbol-value (first args))))
	(cond
	 ((m-unboundp result)
	  (m-error '|Unbound symbol: | (first args)))
	 (t result))))

  (m-defprim symbol-function (args)
   (let ((result (m-symbol-function (first args))))
	(cond
	 ((m-unboundp result)
	  (m-error '|Unbound function: | (first args)))
	 (t result))))


  ;; Primitive Predicates

  (m-defprim boundp (args)
   (not (m-unboundp (m-symbol-value (first args)))))

  (m-defprim symbolp (args)
   (symbolp (first args)))

  (m-defprim fixnump (args)
   (integerp (first args)))

  (m-defprim consp (args)
   (consp (first args)))

  (m-defprim eql (args)
   (eql (first args) (second args)))


  ;; Mutators

  (m-defprim rplaca (args)
   (rplaca (first args) (second args)))

  (m-defprim rplacd (args)
   (rplacd (first args) (second args)))

  (m-defprim set (args)
   (m-set-symbol-value (first args) (second args)))

  (m-defprim set-symbol-function (args)
   (m-set-symbol-function (first args) (second args)))
  
  (m-defspec setq (args)
   (m-set-binding (first args)
		  (m-eval-sexpr (second args))))



  ;; Input/Output Primitives

  (m-defprim read (args)
   (apply #'read args))
  
  (m-defprim princ (args)
   (princ (first args)))
  
  (m-defprim terpri (args)
   (terpri))
  
  (m-defprim load (args)
   (with-open-file (in (string (first args))
		       :direction :input
		       :if-does-not-exist nil)
    (if (not in)
	(m-error '|File not found: | (first args)))
    (do ((sexpr (read in nil 'm-eof)
		(read in nil 'm-eof)))
	((eql sexpr 'm-eof) nil)
	(m-eval-sexpr sexpr))))


  ;; Miscellaneous Primitives
  
  (m-defspec quote (args)
   (first args))
  
  (m-defspec function (args)
   (if (and (consp (first args))
	    (eql (car (first args)) 'lambda))
       `(lambda-closure ,*environment*
			. ,(cdr (first args)))
       (m-check-funarg (first args))))
  
  (m-defspec cond (args)
   (let ((result nil))
	(cond
	 ((null args) nil)
	 ((setf result (m-eval-sexpr (caar args)))
	  (dolist (sexpr (cdar args) result)
		  (setf result (m-eval-sexpr sexpr))))
	 (t (funcall (cdr (m-symbol-function 'cond))
		     ;; The cond primitive calls
		     ;; itself recursively
		     (cdr args))))))
  
  (m-defprim exit (args)
   (throw 'm-exit nil))
  
  (m-defprim error (args)
   (apply #'m-error args))
  
  (m-defprim eval (args)
   (m-eval-sexpr (first args)))
  
  (m-defprim funcall (args)
   (m-apply (m-check-funarg (first args))
	    (rest args)))

  (m-defprim apply (args)
   (m-apply (m-check-funarg (first args))
	    (apply #'list* (rest args))))
  
  (m-defprim macroexpand-1 (sexpr)
   (cond
    ((or (not (consp (first sexpr)))
	 (not (symbolp (first (first sexpr)))))
     sexpr)
    (t (let ((fbinding (m-symbol-function
			(first (first sexpr)))))
	    (cond
	     ((or (not (consp fbinding))
		  (not (eql 'macro (car fbinding))))
	      sexpr)
	     (t (m-apply fbinding
			 (rest (first sexpr)))))))))
  
  )	;; End of m-initialize-primitive-functions

;; Next we give the top level, which does the
;; read-eval-print loop.

;; We have a couple of CATCHes to return from exits and
;; errors.  The main expression evaluator is
;; m-eval-sexpr defined below.

(defun meta-lisp ()
  
  (m-initialize-symbol-table)
  
  (princ '|Welcome to META-LISP.|) (terpri)
  (princ '|Type control-D to exit.|) (terpri)
  (terpri)
  (princ '|-> |)

  (catch 'm-exit	;; throw 'm-exit to quit
	 (do ((sexpr (read nil nil 'm-eof)
		     (read nil nil 'm-eof)))
	     ((eql sexpr 'm-eof))
	     (fresh-line)
	     (setf *environment* nil)
	     (princ
	      (catch 'm-error
		     ;; throw 'm-error to get back
		     ;; to top level from an error
		     (m-eval-sexpr sexpr)))

	     (terpri) (princ '|-> |)))

  (terpri) (princ '|Goodbye|) (terpri))

(defun m-error (&rest args)
  (princ '|META-LISP ERROR: |)
  (mapcar #'princ args)
  (terpri)
  (throw 'm-error NIL))

;; During execution arguments are pushed into a stack
;; stored in the *environment* which contains pairs of
;; the form (argument-name . argument-value), with the
;; most recently bound argument first.
;;
;; Thus during evaluation of
;;
;;	(funcall #'(lambda (x y z) (+ x y z)) 3 4 5)
;;
;; we would want to push (x . 3), (y . 4) and (z . 5)
;; onto the *environment* stack so that stack would look
;; like: 
;;
;;	((z . 5) (y . 4) (x . 3) ...)
;;
;;
;; This is done by calling:
;;
;;	(m-bind-args '(3 4 5) '(x y z)).
;;
;; To handle functions like #'(lambda (&rest x) x)
;; m-bind-args has to be able to handle calls like:
;;
;;	(m-bind-args '(3 4 5) '(&REST X))
;;
;; which push (X . (3 4 5)) into the *environment*.



(defun m-bind-args (args formalargs)
  (cond
   ((and (consp formalargs)
	 (eql '&REST (first formalargs)))
    (cond
     ((not (and (consp (cdr formalargs))
		(symbolp (cadr formalargs))
		(null (cddr formalargs))))
      (m-error '|bad &rest parameter| formalargs))
     (t
      (setf *environment*
	    (cons (cons (cadr formalargs) args)
		  *environment*)))))
   ((and (consp formalargs)
	 (symbolp (first formalargs))
	 (consp args))
    (setf *environment*
	  (cons (cons (car formalargs) (car args))
		*environment*))
    (m-bind-args (cdr args) (cdr formalargs)))

   ((and (null args) (null formalargs))) ;; AOK

   ((and (consp args) (null formalargs))
    (m-error '|actual argument list too long| args))
   ((null args)
    (m-error '|actual argument list too short|))
   ((atom args)
    (m-error '|actual argument list dotted| args))
   (t
    (m-error '|bad formal parameters| formalargs))))



;; When we evaluate the symbol X we have to find the
;; current value of X.  We look in the *environment*
;; first, to see if the symbol is there.  If so, we take
;; its value.  If not, we call:
;;
;;	(m-symbol-value 'X)
;;
;; to get a value.  Similarly SETQ sets the current
;; value of X, so we need to be able to set the
;; *environment* value of X if it exists, or call
;; m-set-symbol-value otherwise.

(defun m-get-binding (sym)
  (let ((binding (assoc sym *environment*)))
       (cond
	(binding (cdr binding))
	(t (m-symbol-value sym)))))

(defun m-set-binding (sym val)
  (let ((binding (assoc sym *environment*)))
       (cond
	(binding (setf (cdr binding) val))
	(t (m-set-symbol-value sym val)))))


;; What are the possible legal function arguments to
;; FUNCALL?
;;
;; We already have defined primitive functions, so
;;
;;	(funcall (cons 'm-primitive F) 1 2 3) ===> 6
;;
;; should work if F is
;;
;;	#'(lambda (args) (apply #'+ args)).
;;
;; as we have defined it above.
;;
;;
;; Another valid function argument to funcall is given
;; in:
;;
;; 	(funcall '(lambda (x) (* x x)) 5) ===> 25.
;;
;;
;; What happens when (lambda (x) (* x x)) is called with
;; the argument 5?  First *environment* is saved and set
;; to NIL.  Then (x . 5) is pushed into the (empty)
;; *environment* stack.  Then (* x x) is evaluated,
;; after which the saved *environment* is restored
;; before the result is returned.
;;
;; Setting the *environment* to NIL before binding the
;; arguments in a call to a '(lambda ...) is important,
;; as illustrated by the code
;;
;;	(setq x 99)
;;	(funcall '(lambda (x)
;;		   (funcall '(lambda () x ))) 11)
;;	    ===> 99
;;

;; However #'(lambda ...) behaves differently!  The #'
;; function binds the current environment into its
;; resulting callable function object.  We choose to
;; implement this by:
;;
;;	#'(LAMBDA args . body) ====>
;;	    '(LAMBDA-CLOSURE *environment* args . body)
;;
;; where the current *environment* has been captured in
;; the resulting closure.  Then when this is called, the
;; *environment* is set to this captured environment
;; instead of NIL.
;;
;; Thus
;;
;;	(setq x 99)
;;	(funcall '(lambda (x)
;;		   (funcall #'(lambda () x ))) 11)
;;	    ===> 11
;;
;; As a more interesting example, given
;;
;;	(defun integers-from (n)
;;	 (cons n #'(lambda () (integers-from (+ n 1)))))
;;
;; and the call
;;
;;	(integers-from 5)
;;
;; then inside the execution of this call, the
;; *environment* is ((N . 5)), and the value returned
;; from the call is
;;
;;	(5 . (LAMBDA-CLOSURE ((N . 5)) NIL
;;			     (INTEGERS-FROM (+ N 1))))
;;

;; When the LAMBDA-CLOSURE is funcall'ed, the
;; *environment* is set to ((N . 5)) instead of NIL when
;; (INTEGERS-FROM (+ N 1)) is evaluated.  This gives the
;; equivalent of (INTEGERS-FROM 6), as desired.
;;
;; Lastly, we must deal with macros.  Macros can only be
;; accessed by expressions of the form (S . args) where
;; S is a symbol that has been defined as a macro.  So
;; we will implement
;;
;;	(defmacro name args . body)
;;	====>
;;	(set-symbol-function 'name '(macro args . body))
;;
;;
;; There is also one last COMMONLISP construct that
;; needs to be implemented:
;;
;;	((lambda args . body) . exps)
;;	===>
;;	(funcall #'(lambda args . body) exps)
;;
;; For example:	((lambda (x) (* x x)) 9) ===> 81


(defun m-eval-sexpr (sexpr)
  (let* ((result nil)
	 (trace-value (m-symbol-value '*trace*))
	 (trace (and (not (m-unboundp trace-value))
		     trace-value)))

   (cond (trace (fresh-line)
		(princ sexpr) (princ '| ==>|)
		(terpri)))

   (cond

    ((integerp sexpr) (setf result sexpr))
	
    ((symbolp sexpr)
     (setf result (m-get-binding sexpr))
     (if (m-unboundp result)
	 (m-error '|Unbound variable: | sexpr)))
	
    ((symbolp (car sexpr))
     (let ((fbinding (m-symbol-function (car sexpr))))
      (cond

       ((m-unboundp fbinding)
	(m-error '|Unbound function: | (car sexpr)))

       ((not (consp fbinding))
	(m-error '|Bad function binding: | (car sexpr)))

       ((eql 'm-special (car fbinding))
	(setf result
	      (funcall (cdr fbinding) (cdr sexpr))))

       ((eql 'macro (car fbinding))
	(setf result
	      (m-eval-sexpr
	       (m-apply fbinding (cdr sexpr)))))
       (t
	(setf result
	      (m-apply (m-check-funarg fbinding)
		       (m-eval-args (cdr sexpr))))))))
	
    ((and (consp (car sexpr))
	  (eql (caar sexpr) 'lambda))
     (setf result
	   (m-apply `(lambda-closure ,*environment*
				     . ,(cdar sexpr))
		    (m-eval-args (cdr sexpr)))))
	
    (t (m-error '|Illegal function -- | (car sexpr))))

   (cond (trace (fresh-line)
		(princ '|==> |) (princ result)
		(terpri)))
   result))


;; The following function is a helper to check whether
;; the function argument to FUNCALL or APPLY is legal.
;; In our implementation
;;
;;	(M-PRIMITIVE . f)
;;	(LAMBDA . args-and-body)
;;	(LAMBDA-CLOSURE . environment-args-and-body)
;;
;; are legal, as are symbols whose symbol-functions are
;; one of these.  However
;;
;;	(MACRO . args-and-body)
;;	(M-SPECIAL . f)
;;
;; are NOT legal function arguments to FUNCALL or APPLY.
;;
;; Check-funarg returns one of the three legal forms
;; above, returning the symbol-function of any symbol
;; given to it, or calls error if it is given a
;; non-legal form or a symbol whose symbol-function is
;; non-legal form.
;;
(defun m-check-funarg (func)
  (let ((fbinding (if (symbolp func)
		      (m-symbol-function func)
		      func)))
       (if (or (not (consp fbinding))
	       (not (member
		     (car fbinding)
		     '(m-primitive lambda
				   lambda-closure))))
	   (m-error '|Illegal function: | func)
	   fbinding)))

;; The following function is a helper such that LISP
;; (APPLY f x) can be implemented as
;;
;;	(m-apply (m-check-funarg f) x)
;;
;; In addition, m-apply can be used with (MACRO ...)
;; functions, which it treats exactly like (LAMBDA ...)
;; functions.  However, it CANNOT be used with special
;; functions because it sets the *environment* to NIL
;; for everything but LAMBDA-CLOSUREs.
;;
(defun m-apply (function args)
  (let ((saved-environment *environment*)
	(formalargs)
	(body)
	(result nil))
   (cond
    ((eql 'm-primitive (car function))
     (setq *environment* nil)
     (setq result (funcall (cdr function) args)))

    (t
     (cond
      ((eql 'lambda-closure (car function))
       (setq *environment* (cadr function))
       (setq formalargs (caddr function))
       (setq body (cdddr function)))
      (t
       (setq *environment* nil)
       (setq formalargs (cadr function))
       (setq body (cddr function))))
     (m-bind-args args formalargs)
     
     (dolist (sexpr body)
	     (setf result (m-eval-sexpr sexpr)))))

   (setf *environment* saved-environment)
   result))

;; A simple little helper function to evaluate all the
;; arguments in a list.
;;
(defun m-eval-args (args)
  (mapcar #'m-eval-sexpr args))