;;; -*- Mode: LISP -*-

;;;; File MINILISP launched 21-Nov-90 14:23. 
;;;; Konverterad till Allegro / AHA 950403

(defun mini-eval (form &optional (env nil)) ; uttryck x symboltabell 
					; -> uttryck
  (cond ((constant? form)(evaluate-constant form))
	((variable? form) (lookup-value form env))
	((conditional? form) (eval-conditional (clauses form) env))
	(t (mini-apply (function-part form)
                       (evalargs (args-part form) env)
                       env))))


(defun evalargs (arg-list env)		; argumentlista x symboltabell 
					; -> argumentlista
  (cond ((empty-args arg-list) '())
	(t (cons (mini-eval (first-arg  arg-list) env)
		 (evalargs (rest-of-args arg-list) env)))))


(defun mini-apply (fn args env)		; funktion x argumentlista x 
					; symboltabell -> uttryck
  (cond ((primitive-function? fn) (primitive-apply fn args))
	((function-symbol? fn)(mini-apply (lookup-definition fn) args env))
	((lambda? fn) (mini-eval (body fn) 
				 (extend-env (bind (formal-params fn)args)
					     env)))
	(t (error "u.d.f-undefinied function ~s" fn))))


(defun eval-conditional (clauses env)	; klausuler x symboltabell -> uttryck
  (cond ((empty-clause-list? clauses) 
	 (error "no clause with true predicate"))
	((true? (mini-eval (predicate (first-clause clauses)) env))
	 (mini-eval (expression (first-clause clauses)) env))
	(t (eval-conditional (rest-of-clauses clauses) env))))


(defun constant? (form)			;uttryck -> lisp-sanningsvärde
  (or (numberp form)
      (eq form nil)
      (eq form t)
      (and (listp form) (eq (first form)'*quote))))


(defun evaluate-constant (form)		; uttryck -> uttryck
  (cond ((numberp form) form)
	((eq form nil) nil)
	((eq form t) t)
	(t (second form))))


(defun lookup-value (form env)		; utryck x symboltabell -> uttryck
  (let ((binding (assoc form env)))
    (cond ((eq binding nil) (error "u.b.v - unbound variable ~s" form))
	  (t (cdr binding)))))


(defun variable? (form)			; uttryck -> Lisp-sanningsvärde
  (symbolp form))


(defun conditional? (form)		; uttryck -> Lisp-sanningsvärde
  (and (listp form)
       (eq (first form) '*cond)))


(defun clauses (form)			; uttryck -> klausuler
  (rest form))


(defun true? (form)			; uttryck -> Lisp-sanningsvärde
  (not (eq form nil)))


(defun empty-args (arg-list)		; argumentlista -> lisp-sanningsvärde
  (endp arg-list))


(defun first-arg (arg-list)		; argumentslita -> uttryck
  (first arg-list))


(defun rest-of-args (arg-list)		; argumentlista -> argumentlista
  (rest arg-list))


(defun empty-clause-list? (clauses)	; klausuler -> Lisp-sanningsvärde
  (endp clauses))


(defun function-part (form)		; uttryck -> funktion
  (first form))


(defun args-part (form)			; uttryck -> argumentlista
  (rest form))


(defun predicate (clause)		; klausul -> uttryck
  (first clause))


(defun expression (clause)		; klausul -> uttryck
  (second clause))


(defun first-clause (clause-list)	; klausuler -> klausul
  (first clause-list))


(defun rest-of-clauses (clause-list)	; klausuler -> klausuler
  (rest clause-list))


(defun primitive-function? (fn)		; funktion -> Lisp-sanningsvärde
  (not (eq (assoc fn primitive-functions)' nil)))


(defun primitive-apply (fn args)	; funktion x argumentlista -> uttryck
  (apply (cdr (assoc fn primitive-functions)) args))


(defun function-symbol? (fn)		; funktion -> Lisp-sanningsvärde
  (symbolp fn))


(defun lookup-definition (fn)		; funktionsnamn -> funktion
  (let ((binding (assoc fn function-definitions)))
    (cond ((eq binding 'nil) (error "u.d.f - undefinied function ~s" fn))
	  (t (cdr binding)))))


(defun lambda? (fn)			; funktion -> Lisp-sanningsvärde
  (and (listp fn) (eq (first fn) '*lambda)))


(defun extend-env (new-bindings old-env) ; bindningar x symboltabell 
					; -> symboltabell
  (append new-bindings old-env))


(defun bind (formals values)		; parameterlista x argumentslista
					; -> bindningar
  (mapcar #'cons formals values))


(defun body (fn)			; lambda-uttryck -> uttryck
  (third fn))


(defun formal-params (fn)		; lambda-uttryck -> parameterlista
  (second fn))


(defparameter function-definitions
    '((second . (*lambda (l) (*car (*cdr l))))
      (fak . (*lambda (n) (*cond ((*eq n 0) 1)
			   (t (*times n (fak (*sub1 n)))))))))

(defparameter primitive-functions 
    '((*car . car)
      (*cdr . cdr)
      (*cons . cons)
      (*symbolp . symbolp)
      (*eq . eq)
      (*null . null)
      (*times . *)
      (*sub1 . 1-)))