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

(define-standard-structure
  continuation
   previous-continuation
   fctn
   machine-state)
  
(define-standard-structure
  history-subproblem
   valid-flag
   previous-subproblem
   next-subproblem
   reductions)

(define-standard-structure
  history-reduction
   valid-flag
   previous-reduction
   next-reduction
   continuation)

(define-standard-structure
  history
   current-subproblem
   current-reduction)

(defun create-double-linked-structures (size maker linker)
  (let ((elements '()))
    (dotimes (count size)
      (push (funcall maker) elements))
    (do ((count 0 (1+ count))
	 (skeleton (apply #'circular-list elements) (rest skeleton)))
	((= count size) elements)
      (let ((this-element (first  skeleton))
	    (next-element (second skeleton)))
	(funcall linker this-element next-element)))))

(defun create-reduction-ring (size)
  (create-double-linked-structures
    size
    #'(lambda ()
	(make-history-reduction
	  :valid-flag nil
	  :previous-reduction   nil
	  :next-reduction       nil
	  :continuation         nil))
    #'(lambda (this-reduction next-reduction)
	(setf (history-reduction-next-reduction     this-reduction) next-reduction)
	      (history-reduction-previous-reduction next-reduction) this-reduction)))

(defun create-subproblem-ring (size reduction-ring-size)
  (create-double-linked-structures
    size
    #'(lambda ()
	(make-history-subproblem
	  :valid-flag nil
	  :previous-subproblem   nil
	  :next-subproblem       nil
	  :reductions            (first (create-reduction-ring reduction-ring-size))))
    #'(lambda (this-subproblem next-subproblem)
	(setf (history-subproblem-next-subproblem     this-subproblem) next-subproblem
	      (history-subproblem-previous-subproblem next-subproblem) this-subproblem))))

(defun create-history (subproblems reductions)
  (let ((s-ring (create-subproblem-ring subproblems reductions)))
    (make-history
      :current-subproblem (first s-ring)
      :current-reduction  (history-subproblem-reductions (first s-ring)))))

(defun spread-history (history receiver)
  (funcall receiver
	   (history-current-subproblem history)
	   (history-current-reduction history)))

(defun rotate-reduction-ring (direction history)
  (let ((next-reduction
	  (funcall direction
	    (history-current-reduction history))))
    (setf (history-current-reduction history) next-reduction)
    next-reduction))

(defun rotate-subproblem-ring (direction history)
  (spread-history history
    #'(lambda (current-subproblem current-reduction)
	(setf (history-subproblem-reductions current-subproblem) current-reduction)
	(let ((next-subproblem (funcall direction current-subproblem)))
	  (setf (history-current-subproblem history) next-subproblem
		(history-current-reduction  history) (history-subproblem-reductions next-subproblem))
	  next-subproblem))))

(defvar *maximum-subproblems-to-record* 10.)
(defvar *maximum-reductions-to-record*   5.)

(defvar *history*)

(defun print-cont-result (values)
  (inspect values)
  (format t "~%Returning to LISP~% ~S" values))

(defun startup (fctn arglist)
  (setq *history* (create-history *maximum-subproblems-to-record*
				  *maximum-reductions-to-record*))
  (top-level-continuation-driver
    fctn
    (make-continuation
      :previous-continuation ()
      :fctn                  #'print-cont-result
      :machine-state         ())
    arglist))

(defun top-level-continuation-driver (initial-fctn initial-continuation initial-state)
  (do ((fctn         initial-fctn)
       (continuation initial-continuation)
       (state        initial-state))
      ((null continuation) (apply fctn state))
    (let ((next-continuation
	    (catch 'continue
	      (apply fctn continuation state))))
; Debugging
;      (format t "~%Received ~S ~S ~S"
;	      (continuation-fctn                  next-continuation)
;	      (continuation-machine-state         next-continuation)
;	      (continuation-previous-continuation next-continuation))
      (setq fctn         (continuation-fctn                  next-continuation)
	    continuation (continuation-previous-continuation next-continuation)
            state        (continuation-machine-state         next-continuation)))))

(defun do-reduction (fctn continuation arglist)
  (let ((reduction-continuation
	  (make-continuation
	    :previous-continuation continuation
	    :fctn                  fctn
	    :machine-state         arglist)))
    (let ((reduction (rotate-reduction-ring #'history-reduction-next-reduction *history*)))
      (setf (history-reduction-continuation reduction) reduction-continuation
	    (history-reduction-valid-flag   reduction) t))
    (throw 'continue reduction-continuation)))

(defun do-subproblem (subproblem-fctn subproblem-args
		      current-continuation
		      return-fctn return-args)
  (let ((return-continuation (make-continuation
			       :previous-continuation current-continuation
			       :fctn                  return-fctn
			       :machine-state         return-args))
	(next-subproblem (rotate-subproblem-ring #'history-subproblem-next-subproblem *history*)))
    (setf (history-subproblem-valid-flag next-subproblem) t
	  (history-reduction-valid-flag (history-subproblem-reductions next-subproblem)) nil)
    (do-reduction subproblem-fctn return-continuation subproblem-args)))

(defun do-return (continuation return-value)
  (setf (continuation-machine-state continuation)
	   (cons return-value (continuation-machine-state continuation))
	(history-subproblem-valid-flag (history-current-subproblem *history*)) nil)
  (rotate-subproblem-ring #'history-subproblem-previous-subproblem *history*)
  (throw 'continue continuation))

(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 (lisp-symbol) (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)))

;;; Simple syntaxer written in Common Lisp.

(defvar *external-syntax-table* '())

(defun external-syntax (expression)
  (if (symbol? expression)
      (syntax-variable expression)
      (let ((syntaxer-pair (assq (first expression) *external-syntax-table*)))
	(if (null? syntaxer-pair)
	    (syntax-combination expression)
	    (apply (cadr syntaxer-pair) (rest expression))))))

(defun syntax-variable (expression)
  (make-instance 'c-variable
		 :symbol expression
		 :depth  nil
		 :offset nil))

(defun syntax-combination (expression)
  (make-instance 'combination
		 :guts (mapcar #'external-syntax expression)))


(defun syntax-define (name value)
  (make-instance 'definition
		 :identifier name
		 :value (external-syntax value)))

(push (list 'define #'syntax-define) *external-syntax-table*)

(defun syntax-set (name value)
  (make-instance 'assignment
		 :identifier name
		 :value (external-syntax value)))

(push (list 'set! #'syntax-set) *external-syntax-table*)

(defun syntax-named-lambda (bound-variables body)
  (make-instance 'lambda
		 :bound-variables bound-variables
		 :body (external-syntax body)))

(push (list 'named-lambda #'syntax-named-lambda) *external-syntax-table*)

(defun syntax-sequence (&rest expressions)
  (labels
    ((syntax-sequence-internal (elist)
       (let ((exp1 (external-syntax (first elist)))
	     (others (rest  elist)))
       (if (null? others)
	   exp1
	   (make-instance 'sequence
			  :first-form exp1
			  :second-form (syntax-sequence-internal others))))))
    (syntax-sequence-internal expressions)))

(push (list 'sequence #'syntax-sequence) *external-syntax-table*)

(defun syntax-quote (object)
  (make-instance 'external-list-structure
		 :external-object object))

(push (list 'quote #'syntax-quote) *external-syntax-table*)

(defun syntax-the-environment ()
  (make-instance 'the-environment))

(push (list 'the-environment #'syntax-the-environment) *external-syntax-table*)