;; CPS-Interpreter mit Registern

;; Scheme-Ausdrücke als Datentyp

(define variable?
  (lambda (form)
    (symbol? form)))

(define variable-name
  (lambda (form)
    form))

;; Kombinationen lassen sich an ihrem Operator erkennen

(define make-combination-predicate
  (lambda (name)
    (lambda (form)
      (and (pair? form)
	   (eq? name (car form))))))

(define define? (make-combination-predicate 'define))

(define define-variable-name
  (lambda (form)
    (car (cdr form))))

(define define-expression
  (lambda (form)
    (car (cdr (cdr form)))))

(define quote? (make-combination-predicate 'quote))

(define quote-constant
  (lambda (form)
    (car (cdr form))))

(define literal?
  (lambda (form)
    (or (quote? form)
	(and (not (pair? form))
	     (not (variable? form))))))

(define literal-constant
  (lambda (form)
    (if (quote? form)
	(quote-constant form)
	form)))

(define lambda? (make-combination-predicate 'lambda))

(define lambda-parameters
  (lambda (form)
    (car (cdr form))))

(define lambda-body
  (lambda (form)
    (car (cdr (cdr form)))))

(define if? (make-combination-predicate 'if))

(define if-test
  (lambda (form)
    (car (cdr form))))

(define if-consequent
  (lambda (form)
    (car (cdr (cdr form)))))

(define if-alternative
  (lambda (form)
    (car (cdr (cdr (cdr form))))))

(define set!? (make-combination-predicate 'set!))

(define set!-variable-name
  (lambda (form)
    (car (cdr form))))

(define set!-expression
  (lambda (form)
    (car (cdr (cdr form)))))

(define begin? (make-combination-predicate 'begin))

(define begin-expressions
  (lambda (form)
    (cdr form)))

(define let/cc? (make-combination-predicate 'let/cc))

(define let/cc-name
  (lambda (form)
    (car (cdr form))))

(define let/cc-expression
  (lambda (form)
    (car (cdr (cdr form)))))

;; Eine Applikation ist eine Kombination, die zu keiner der oberen
;; Kombinationssorten gehört

(define application-operator
  (lambda (form)
    (car form)))

(define application-operands
  (lambda (form)
    (cdr form)))

;; Primitive und ganz normale Werte

(define primitive-value-type (make-type 'primitive-value))
  
(define make-primitive-value
  (lambda (value)
    (make-typed-object primitive-value-type value)))

(define value-primitive?
  (typed-object-predicate primitive-value-type))

(define primitive-value
  (lambda (value)
    (typed-object-value primitive-value-type value)))

(define ordinary-value-type (make-type 'ordinary-value))

(define make-ordinary-value
  (lambda (value)
    (make-typed-object ordinary-value-type value)))

(define value-ordinary?
  (typed-object-predicate ordinary-value-type))

(define ordinary-value
  (lambda (value)
    (typed-object-value ordinary-value-type value)))

(define continuation-type (make-type 'continuation-value))

(define make-continuation
  (lambda (value)
    (make-typed-object continuation-type value)))

(define value-continuation?
  (typed-object-predicate continuation-type))

(define continuation-value
  (lambda (value)
    (typed-object-value continuation-type value)))

;; Prozeduren werden durch Closures repräsentiert

(define closure-type (make-type 'closure))

(define make-closure
  (lambda (parameters body environment)
    (make-typed-object
     closure-type
     (cons (cons parameters body)
	   environment))))

(define closure-parameters
  (lambda (closure)
    (car (car (typed-object-value closure-type closure)))))

(define closure-body
  (lambda (closure)
    (cdr (car (typed-object-value closure-type closure)))))

(define closure-environment
  (lambda (closure)
    (cdr (typed-object-value closure-type closure))))

;; Umgebungen

(define environment-type (make-type 'environment))

(define make-environment
  (lambda (frame enclosing-environment)
    (make-typed-object
     environment-type
     (cons frame enclosing-environment))))

(define environment-frame
  (lambda (environment)
    (car (typed-object-value environment-type environment))))

(define environment-enclosing-environment
  (lambda (environment)
    (cdr (typed-object-value environment-type environment))))

;; Frames bestehen aus Bindungen

(define frame-type (make-type 'frame))

(define make-frame
  (lambda (bindings)
    (make-typed-object frame-type
		       (cons bindings #f))))

(define frame-bindings
  (lambda (frame)
    (car (typed-object-value frame-type frame))))

;; Eine Bindung ist ein Paar aus Variablenname und Wert

(define extend-frame!
  (lambda (frame name value)
    (let ((frame-cell (typed-object-value frame-type frame)))
      (set-car! frame-cell
		(cons (cons name value) (car frame-cell))))))

(define frame-lookup-binding
  (lambda (frame name)
    (assoc name (frame-bindings frame))))

(define environment-lookup-binding
  (lambda (environment name)
    (let ((try-here (frame-lookup-binding (environment-frame environment) name)))
      (if try-here
	  try-here
	  (let ((enclosing-environment
		 (environment-enclosing-environment environment)))
	    (if enclosing-environment
		(environment-lookup-binding enclosing-environment name)
		#f))))))

(define environment-lookup
  (lambda (environment name)
    (let ((stuff (environment-lookup-binding environment name)))
      (if stuff
	  (cdr stuff)
	  #f))))

(define environment-mutate-binding!
  (lambda (environment name new-value)
    (let ((binding (environment-lookup-binding environment name)))
      (set-cdr! binding new-value))))

;; Die globale Umgebung enthält einige Primitiva

(define make-global-environment
  (lambda ()
    (make-environment
      (make-frame
       (list
	(cons '+ (make-primitive-value +))
	(cons '* (make-primitive-value *))
	(cons '= (make-primitive-value =))
	(cons '- (make-primitive-value -))))
      #f)))

;; Der Wert von Zuweisungen

(define unspecific-value
 (make-ordinary-value 'unspecific))

;; EVALUATE wertet einen Ausdruck in bezug auf eine Umgebung aus

(define *expression* #f)
;; Unausgewertete Ausdrücke in BEGIN-Ausdruck oder Anwendung
(define *expressions* #f)
;; Ausgewertete Operanden in Prozeduranwendung oder Programmauswertung
(define *reverse-values* #f)
(define *values* #f)
(define *environment* #f)
(define *k* #f)
(define *val* #f)

(define evaluate
  (lambda ()
    (cond
     ((literal? *expression*)
      (set! *val* (make-ordinary-value (literal-constant *expression*)))
      (*k*))
     ((variable? *expression*)
      (set! *val* (environment-lookup *environment*
				      (variable-name *expression*)))
      (*k*))
     ((if? *expression*)
      (let ((consequent (if-consequent *expression*))
	    (alternative (if-alternative *expression*)))
	(set! *expression* (if-test *expression*))
	(set! *k*
	      (let ((previous-k *k*)
		    (previous-environment *environment*))
		(lambda ()
		  (set! *k* previous-k)
		  (set! *environment* previous-environment)
		  (if (ordinary-value *val*)
		      (set! *expression* consequent)
		      (set! *expression* alternative))
		  (evaluate))))
	(evaluate)))
     ((set!? *expression*)
      (let ((variable-name (set!-variable-name *expression*)))
	(set! *expression* (set!-expression *expression*))
	(set! *k*
	      (let ((previous-k *k*)
		    (previous-environment *environment*))
		(lambda ()
		  (set! *k* previous-k)
		  (set! *environment* previous-environment)
		  (environment-mutate-binding! *environment*
					       variable-name *val*)
		  (set! *val* unspecific-value)
		  (*k*))))
	(evaluate)))
     ((begin? *expression*)
      (set! *expressions* (begin-expressions *expression*))
      (letrec ((loop
		(lambda ()
		  (if (null? *expressions*)
		      (*k*)
		      (begin
			(set! *k*
			      (let ((previous-k *k*)
				    (previous-environment *environment*)
				    (previous-expressions *expressions*))
				(lambda ()
				  (set! *k* previous-k)
				  (set! *environment* previous-environment)
				  (set! *expressions*
					(cdr previous-expressions))
				  (loop))))
			(set! *expression* (car *expressions*))
			(evaluate))))))
	(loop)))
     ((let/cc? *expression*)
      (let* ((continuation (make-continuation *k*))
	     (frame (make-frame (list (cons (let/cc-name *expression*)
					    continuation))))
	     (environment
	      (make-environment frame *environment*)))
	(set! *expression* (let/cc-expression *expression*))
	(set! *environment* environment)
	(evaluate)))
     ((lambda? *expression*)
      (set! *val*
	    (make-ordinary-value
	     (make-closure (lambda-parameters *expression*)
			   (lambda-body *expression*)
			   *environment*)))
      (*k*))
     (else ;; Prozeduranwendung
      (set! *expressions* (application-operands *expression*))
      (set! *expression* (application-operator *expression*))
      (set!
       *k*
       (let ((previous-k *k*)
	     (previous-environment *environment*)
             (previous-expressions *expressions*))
	 (lambda ()
	   (set! *k* previous-k)
	   (set! *environment* previous-environment)
           (set! *expressions* previous-expressions)
	   (set! *reverse-values* '())
	   (letrec ((loop
		     (lambda ()
		       (if (null? *expressions*)
			   (begin
			     (set! *values* (reverse *reverse-values*))
			     (apply-procedure))
			   (begin
			     (set!
			      *k*
			      (let ((previous-k *k*)
				    (previous-environment *environment*)
				    (previous-expressions *expressions*)
				    (previous-val *val*)
				    (previous-values *reverse-values*))
				(lambda ()
				  (set! *k* previous-k)
				  (set! *environment* previous-environment)
				  (set! *expression*
					(car previous-expressions))
				  (set! *expressions*
					(cdr previous-expressions))
				  (set! *reverse-values* previous-values)
				  (set! *reverse-values*
					(cons *val* *reverse-values*))
				  (set! *val* previous-val)
				  (loop))))
			     (set! *expression* (car *expressions*))
			     (evaluate))))))
	     (loop)))))
      (evaluate)))))

;; APPLY-PROCEDURE wertet eine Prozedur auf die Werte der Operanden
;; der Anwendung an

(define apply-procedure
  (lambda ()
    (cond
     ((value-primitive? *val*)
      (set! *val*
	    (make-ordinary-value
	     (apply (primitive-value *val*)
		    (map ordinary-value *values*))))
      (*k*))
     ((value-ordinary? *val*)
      (let* ((closure (ordinary-value *val*))
	     (parameters (closure-parameters closure))
	     (new-frame
	      (make-frame (zip parameters *values*)))
	     (environment
	      (make-environment new-frame
				(closure-environment closure))))
	(set! *expression* (closure-body closure))
	(set! *environment* environment)
	(evaluate)))
     ((value-continuation? *val*)
      (let ((cont *val*))
	(set! *val* (car *values*))
	((continuation-value cont)))))))

;; ZIP macht aus zwei Listen eine Liste von Paaren

(define zip
  (lambda (list-1 list-2)
    (letrec
	((loop
	  (lambda (list-1 list-2 reverse-result)
	    (if (null? list-1)
		(reverse reverse-result)
		(loop (cdr list-1) (cdr list-2)
		      (cons (cons (car list-1) (car list-2))
			    reverse-result))))))
      (loop list-1 list-2 '()))))

;; Ein Programm besteht aus Definitionen und Ausdrücken

;; Hier die Änderung gegenüber der ursprünglichen Fassung aus der
;; Vorlesung:

;; Vormals wurde das *EXPRESSIONS*-Register für die Formen des
;; Programms benutzt.  Dies wird jedoch auch von EVALUATE benutzt und
;; dort überschrieben.  Darum ist ein neues Register
;; *PROGRAM-EXPRESSIONS* vonnöten.

;; (Vielen an Florian Steinke und Dennis Göhlsdorf für Problemdiagnose
;; und Korrektur.)

(define *program-expressions* #f)
(define *reverse-program-values* #f)

(define evaluate-program
  (lambda (forms)
    (let ((global-environment (make-global-environment)))
      (set! *reverse-program-values* '())
      (set! *program-expressions* forms)
      (letrec
	  ((loop
	    (lambda ()
	      (cond
	       ((null? *program-expressions*) 'done)
	       ((define? (car *program-expressions*))
		(let ((name (define-variable-name
			      (car *program-expressions*))))
		  (set! *expression*
			(define-expression (car *program-expressions*)))
		  (set! *program-expressions* (cdr *program-expressions*))
		  (set! *environment* global-environment)
		  (set! *k* (lambda () 'done))
 		  (evaluate)
		  (extend-frame! (environment-frame
				  global-environment)
				 name
				 *val*)
		  (loop)))
	       (else
		(set! *expression* (car *program-expressions*))
		(set! *program-expressions* (cdr *program-expressions*))
		(set! *environment* global-environment)
		(set! *k* (lambda () 'done))
 		(evaluate)
		(set! *reverse-program-values*
		      (cons *val* *reverse-program-values*))
		(loop))))))
	(loop))
      (map ordinary-value (reverse *reverse-program-values*)))))