;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:CL -*-

(defun scode-eval (cont object environment)
  (send object :scode-eval cont environment))

(defun scode-apply (cont object arglist)
  (send object :scode-apply cont arglist))

(defflavor s-object () ()
  (:required-methods :scode-eval :scode-apply))

;;; Self evaluating

(defflavor self-eval-mixin () ())

(defmethod (self-eval-mixin :scode-eval) (cont environment)
  (declare (ignore environment))
  (do-return cont self))

(defflavor apply-error-mixin () ())

(defmethod (apply-error-mixin :scode-apply) (cont arglist)
  (declare (ignore cont arglist))
  (ferror 'nil "Application of non-procedure-object ~S." self))

(defflavor external-lisp-object (external-object) ()
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)
  
;;; Numbers

(defflavor number () (external-lisp-object self-eval-mixin apply-error-mixin))

;;; Symbols

(defflavor scheme-symbol () (external-lisp-object apply-error-mixin self-eval-mixin s-object))

;;; External list structure (used to make read easier)

(defflavor external-list-structure () (external-lisp-object self-eval-mixin apply-error-mixin s-object))

(defmethod (external-list-structure spread) (if-null if-symbol if-number if-list)
  (cond ((null?   external-object)
	      (funcall if-null))
	((number? external-object)
	      (funcall if-number (make-instance 'number :external-object external-object)))
	((symbol? external-object)
	      (funcall if-symbol (make-instance 'scheme-symbol :external-object external-object)))
	((pair?   external-object)
	      (funcall if-list
		       (make-instance 'external-list-structure :external-object (car external-object))
		       (make-instance 'external-list-structure :external-object (cdr external-object))))))

;;; Quoted

(defflavor quoted (object) (apply-error-mixin s-object)
  :gettable-instance-variables
  :initable-instance-variables)

(defmethod (quoted :scode-eval) (cont environment)
  (declare (ignore environment))
  (do-return cont object))

;;; Procedure

(defflavor procedure (environment lambda) (self-eval-mixin s-object)
  :gettable-instance-variables
  :initable-instance-variables)
  
(defmethod (procedure :scode-apply) (cont arglist)
  (do-reduction cont
    #'scode-eval (list (send lambda :body) (make-environment lambda arglist))))

;;; Lambda

(defflavor lambda (bound-variables body) (apply-error-mixin s-object)
  :gettable-instance-variables
  :initable-instance-variables)

(defmethod (lambda :scode-eval) (cont environment)
  (do-return cont (make-instance 'procedure
				 :environment environment
				 :lambda      self)))

;;; Primitive

(defflavor primitive-procedure () (external-lisp-object self-eval-mixin s-object)
  :gettable-instance-variables
  :initable-instance-variables)

(defmethod (primitive-procedure :scode-apply) (cont arglist)
  (do-return cont (apply external-object arglist)))

;;; Delay and delayed

(defflavor delayed (environment-or-flag code-or-value)
	   (apply-error-mixin self-eval-mixin s-object)
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)

(defflavor delay (form) (apply-error-mixin s-object)
  :gettable-instance-variables
  :initable-instance-variables)

(defmethod (delay :scode-eval) (cont environment)
  (do-return cont (make-instance 'delayed
				 :environment-or-flag environment
				 :code-or-value       self)))

;;; Continuations

(defflavor scode-continuation () (external-lisp-object self-eval-mixin s-object)
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)

(defmethod (scode-continuation :scode-apply) (cont arglist)
  (declare (ignore cont))
  (do-return external-object arglist))

;;; The environment

(defflavor the-environment () (apply-error-mixin s-object))

(defmethod (the-environment :scode-eval) (cont environment)
  (do-return cont environment))
 
;;; Sequence

(defflavor sequence (first-form second-form) (apply-error-mixin s-object)
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)

(defmethod (sequence :scode-eval) (cont environment)
  (do-subproblem #'scode-eval (list first-form environment)
		 cont
		 #'scode-eval (list second-form environment)))

;;; Bindings and Environments

(defflavor binding (name shadowed? value) (apply-error-mixin self-eval-mixin s-object)
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)

(defflavor environment (internal-environment) (apply-error-mixin self-eval-mixin s-object)
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)
  
(defun make-environment (procedure &rest args)
  (make-instance 'environment
		 :internal-environment
		 (apply #'vector
			'()
			'()
			(map 'list #'(lambda (name value)
				       (make-instance 'binding
						      :name      name
						      :shadowed? nil
						      :value     value))
			     (send procedure :bound-variables)
			     (cons procedure args)))))

(defmacro environment-incrementals (internal-environment)
  `(elt ,internal-environment 0))

(defmacro environment-potentially-shadowed (internal-environment)
  `(elt ,internal-environment 1))

(defmethod (environment :environment-parent) ()
  (send (elt internal-environment 2) :environment))
	
(defmethod (environment :locate-in-frame) (symbol if-found if-not-found)
  (block quit
    (do ((index 0 (1+ index)))
	((= index (length internal-environment)) (return-from quit (funcall if-not-found)))
      (let ((binding (elt internal-environment index)))
	(when (eq? (send binding :name) symbol)
	  (return-from quit (funcall if-found index binding)))))
    (dolist (inc (environment-incrementals internal-environment))
      (when (eq? (send inc :name) symbol)
	(return-from quit (funcall if-found 0 inc))))))

(defmethod (environment :cached-lookup) (c-var depth offset)
  (let ((symbol (send c-var :symbol)))
    (labels ((deep-search (e)
	       (send e :locate-in-environment symbol
		 #'(lambda (depth offset binding)
		     (send c-var :set-depth depth)
		     (send c-var :set-offset offset)
		     binding)
		 #'(lambda () (ferror 'nil "Broken C-Variable")))))
      (do ((d depth (1- depth))
	   (e self (send self :environment-parent)))
	  ((zero? d)
	   (let ((candidate
		   (if (zero? offset)
		       (assoc symbol (environment-incrementals (send e :internal-environment)))
		       (elt (send e :internal-environment) offset))))
	     (if (or (null? candidate)
		     (send candidate :shadowed?))
		 (deep-search self)
		 candidate)))))))

(defmethod (environment :incremental-bind) (symbol value)
  (let ((lself self)
	(linternal-environment internal-environment));; lexical self
    (send self :locate-in-frame
	  #'(lambda (offset binding)
	      (declare (ignore offset))
	      (send binding :set-value value))
	  #'(lambda ()
	      (let ((binding
		      (make-instance 'binding
			:name symbol
			:shadowed?
			      (if (member symbol
					  (environment-potentially-shadowed
					    linternal-environment))
				  t
				  nil))))
		(setf (environment-incrementals linternal-environment)
		      (cons binding (environment-incrementals linternal-environment)))
		(do ((e (send lself :environment-parent) (send e :environment-parent)))
		    ((null? e) nil)
		  (pushnew symbol
			   (environment-incrementals (send e :internal-environment)))))))))

(defmethod (environment :locate-in-enviroment) (symbol if-found if-not-found)
  (let ((depth 0)
	(lself self))
    (block quit
      (tagbody search
	  (if (null? internal-environment)
	      (funcall if-not-found)
	      (send lself :locate-in-frame symbol
		    #'(lambda (offset-in-frame binding)
			(return-from quit (funcall if-found depth offset-in-frame binding)))
		    #'(lambda ()
			(setq lself (send lself :environment-parent))
			(setq depth (1+ depth))
			(go search))))))))

;;; variables

;all the work is done by the environment.

(defflavor c-variable (symbol depth offset) (apply-error-mixin s-object)
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)

(defmethod (c-variable :lookup) (environment if-found if-not-found)
  (let ((lself self))
    (if (null? depth)
	(send environment :locate-in-environment symbol
	      #'(lambda (new-depth new-offset binding)
		  (send lself :set-depth new-depth)
		  (send lself :set-offset new-offset)
		  (funcall if-found binding))
	      #'(lambda ()
		  (funcall if-not-found)))
	(send environment :cached-lookup self))))

(defmethod (c-variable :scode-eval) (cont environment)
  (let ((binding (send self :lookup environment
		       #'values
		       #'(lambda () (ferror 'nil "Unbound variable")))))
    (do-return cont (send binding :value))))

;;; Set!

(defflavor assignment (identifier value) (apply-error-mixin s-object)
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)

(defmethod (assignment :scode-eval) (cont environment)
  (labels ((assign (cont computed-value id)
	     (let ((binding (send id :lookup
			      #'values
			      #'(lambda () (ferror 'nil "Unbound variable")))))
	       (let ((old-value (send binding :value)))
		 (send binding :set-value computed-value)
		 (do-return cont old-value)))))
    (do-subproblem #'scode-eval (list value environment)
		   cont
		   #'assign (list identifier))))

;;; Define

(defflavor definition (identifier value) (apply-error-mixin s-object)
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)

(defmethod (definition :scode-eval) (cont environment)
  (labels ((define (cont computed-value id)
	     (let ((symbol id))
	       (send environment :incremental-bind symbol computed-value)
	       (do-return cont symbol))))
    (do-subproblem #'scode-eval (list value environment)
		   cont
		   #'define (list identifier))))
  
;;; Combination

(defflavor combination (guts) (apply-error-mixin s-object)
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)

;(defmethod (combination :scode-eval) (cont environment)
;  (labels ((accumulate-args (cont args)
;	     (format t "Accumulating ~S" args)
;	     (if (null? args)
;		 (do-return cont '())
;		 (do-subproblem
;		   #'accumulate-args (list (rest args))
;		   cont
;		   #'(lambda (cont evaled-args)
;		       (do-subproblem
;			 #'scode-eval (cons (first args) environment)
;			 cont
;			 #'(lambda (cont evaled)
;			     (do-return cont (cons evaled evaled-args))) '())) '()))))
;    (accumulate-args
;      #'(lambda (vals)
;	  (do-reduction cont #'scode-apply vals))
;      guts)))


(defmethod (combination :scode-eval) (cont environment)
  (labels (
    (accumulate-args (cont evaled unevaled)
      (if (null? unevaled)
	  (let ((revaled (reverse evaled)))
	    (let ((operator (first revaled))
		  (operands (rest  revaled)))
	      (do-reduction #'scode-apply cont (list operator operands))))
	  (do-subproblem #'scode-eval (list (first unevaled) environment)
			 cont
			 #'(lambda (cont evaled-arg)
			     (do-reduction #'accumulate-args cont
					   (list (cons evaled-arg evaled) (rest unevaled)))) '()))))
    (accumulate-args cont '() guts)))