The compiler frontend

fwd2.lisp

;; Examples
;;------------------------------------------------------------------------------
;; 1. non-commands
;;   There are two types of 'non-commands',
;;     a) integers
;;     b) symbols
;;
;;   Symbols are looked up, so if you provide an initial environment, with a 
;;   symbol defined, it will be appropriately looked up.
;;     e.g: (lookup 'x '((x . 0))) -> 0
;;   Lambdas are not necessary, but it would be trivial to add them by providing a
;;   lambda form in the evaluator.
;;
;;  (eval1 1 nil)         -> 1
;;  (eval1 'x '((x . 0))) -> 0

;; 2. commands

;; (i m n)        -> (setf image (make-image n m))
;; (c)            -> (clear image)
;; (l x y c)      -> (colour-pixel image x y c)
;; (v x y1 y2 c)  -> (draw-vertical-segment image x y1 y2 c)
;; (h x1 x2 y c)  -> (draw-horizontal-segment image x1 x2 y c)
;; (f x y c)      -> (fill-region image x y c)
;; (s)            -> (show image)
;; (x)            -> (terminate)
;;
;; e.g: (eval1 '(i (i 0 1) 1) nil)
;; compiles to: (SETF IMAGE (MAKE-IMAGE (SETF IMAGE (MAKE-IMAGE 0 1)) 1))
;; where: image is a dynamically bound variable
;;
(eval1 '(l 1 2 3) nil)
;;
;; Since the compiled forms compile to common-lisp primitives, our evaluator
;; is not powerful enough to run them. However, common-lisp can compile these
;; in turn to native code. :)

(defun compile1 (exp)
  "Compiles a primitive command to common-lisp."
  (cond ((or (integerp exp)
	     (characterp exp))
	 exp)
	((eq (car exp) 'i) 
	 `(setf image (make-image ,@(cdr exp))))
	((eq (car exp) 'c)
	 `(clear image))
	((eq (car exp) 'l)
	 `(colour-pixel image ,@(cdr exp)))
	((eq (car exp) 'v)
	 `(draw-vertical-segment image ,@(cdr exp)))
	((eq (car exp) 'h)
	 `(draw-horizontal-segment image ,@(cdr exp)))
	((eq (car exp) 'f)
	 `(fill-region image ,@(cdr exp)))
	((eq (car exp) 's)
	 `(show image ,@(cdr exp)))
	((eq (car exp) 'x)
	 `(terminate))
	(t
	 (error "Unrecognised expression..."))))

(defun eval-sequence (exps env)
  "Evaluates a sequence of expressions."
  (loop for exp in exps 
	collect (eval1 exp env)))

(defun lookup (symbol env)
  "Looks up a symbol in an environment."
  (loop for s in env do
    (when (eq symbol (car s))
      (return (cdr s)))
	:finally (error "Symbol undefined")))

(defun extend-environment (env args params)
  "Extends an environment with a set of parameters."
  (append env
	  (loop for arg in args
		for param in params
		collect (cons arg param))))

(defun eval1 (exp env)
  "Evaluates an expression within an environment."
  (cond ((or (integerp exp)
	     (characterp exp))
	 exp)
	((symbolp exp)
	 (lookup exp env))
	(t 
	 (apply1 (car exp)
		 (eval-sequence (cdr exp) env)
		 env))))

(defun primitive-command? (fn-name)
  "Is this expression a primitive command?"
  (loop for primitive in '(i c l v h s f x) do
    (when (eq primitive fn-name)
      t)
    finally (return nil)))

(defun apply1 (fn-name params env)
  "Apply a function to a set of parameters within an environment."
  (if (primitive-command? fn-name)
      (compile1 (cons fn-name params))
      (let ((proc (lookup fn-name env)))
       (cond ((> (length (car proc)) params)
	      (error "Not enough parameters supplied to function"))
	     ((< (length (car proc)) params)
	      (error "Too many parameters supplied to function"))
	     (t
	      (eval1 (cdr proc) (extend-environment env (car proc) params)))))))