;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;	Blather
;;	Kulisics, Joseph D.
;;	2008 April 17
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;	Blather extends the core of a basic, meta-circular
;;	evaluator of Scheme to incorporate a pattern matcher
;;	into the control structure of the interpreter and
;;	provide language-level access to pattern matching.
;;	The language-level extension will support a kind
;;	of pattern driven dispatch and reflection. To
;;	support multiple matches to a pattern as part of a
;;	new call syntax, the control structure will need to
;;	incorporate modifications to the apply function
;;	to support match objects in the operator position
;;	in an S-expression. 
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;	DEBUG DEFINITIONS
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define table-debug #f)
(define eval-debug #f)
(define define-variable-debug #f)
(define update-variable-debug #f)
(define define-function-debug #f)
(define apply-compound-procedure-debug #f)

(define run #t)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;	General Purpose Definitions
;;	For Portability
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define write-line
   (lambda args
      (begin
         (write args)
	 (newline))))

(define false #f)
(define true #t)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;	Table Definition
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define make-table
   (lambda ()
      (let
         ((table '())
	  (key-name caar)
	  (key-value cdar)
	  (table-head car)
	  (table-rest cdr))
         (letrec
	    ((lookup
	        (lambda (key)
	           (letrec
		      ((lookup-private
		          (lambda (key table)
		             (cond ((null? table) false)
		   	           ((eq? (key-name table) key) (key-value table))
				   (else (lookup-private key (table-rest table)))))))
                      (lookup-private key table))))
             (update!
	        (lambda (key value)
	           (letrec
		      ((update-private!
		          (lambda (key value table)
		             (cond ((null? table) (insert! key value))
		   	           ((eq? (key-name table) key) (set-cdr! (table-head table) value))
				   (else (update-private! key value (table-rest table)))))))
                      (update-private! key value table))))
	     (insert!
	        (lambda (key value)
	           (letrec
		      ((insert-private!
		          (lambda (key value valuetable)
		             (if (lookup key)
                                (update! key value)
				(set! table (cons (cons key value) table))))))
                      (insert-private! key value table)))))
            (let
	       ((dispatch
	           (lambda (message)
		      (cond ((eq? message 'update!) update!)
		            ((eq? message 'insert!) insert!)
			    ((eq? message 'lookup) lookup)
			    ((eq? message 'dump) table)
			    (else (write-line "make-table::dispatch: ERROR: unknow operation " operation))))))
               dispatch)))))

(if table-debug
   (let
      ((newtable (make-table)))
      (let
         ((insert! (lambda (key value) ((newtable 'insert!) key value)))
	  (lookup (lambda (key) ((newtable 'lookup) key))))
         (begin
            (insert! '1 '1)
            (insert! 'test1 'test2)
            (insert! 'test2 'test2)
            (insert! 'test2 'test3)
            (lookup '1)
            (lookup 'test1)
            (lookup 'test2)
	    (newtable 'dump))))
   'table-debug)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;	Frame Definition
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define make-frame (lambda (variables values) (cons variables values)))

(define frame-variables (lambda (frame) (car frame)))

(define frame-values (lambda (frame) (cdr frame)))

(define variable-in-frame?
   (lambda (variable frame)
      (let
         ((variables (frame-variables frame))
          (values (frame-values frame)))
	 (cond ((null? variables) false)
	       ((eq? (car variables) variable) true)
	       (else (variable-in-frame? variable (make-frame (cdr variables) (cdr values))))))))
	       
(define frame-lookup
  (lambda (variable frame)
     (let
        ((variables (frame-variables frame))
	 (values (frame-values frame)))
	(cond ((null? variables) (error "Lookup of unbound variable--FRAME-LOOKUP" variable))
	      ((eq? (car variables) variable) (car values))
	      (else (frame-lookup variable (make-frame (cdr variables) (cdr values))))))))

(define add-binding-to-frame!
   (lambda (variable value frame)
      (letrec
         ((variable-in-list?
	     (lambda (variable variables)
	        (cond ((null? variables) false)
		      ((eq? variable (car variables)) true)
		      (else (variable-in-list? variable (cdr variables))))))
          (purge-variable!
	     (lambda (variable frame)
	        (let
		   ((variables (frame-variables frame))
		    (values (frame-values frame)))
                   (cond ((eq? variable (car variables)) (make-frame (cdr variables) (cdr values)))
		         (else (add-binding-to-frame! (car variables) (car values) (purge-variable! variable (make-frame (cdr variables) (cdr values)))))))))
          (insert-variable-value-frame!
	     (lambda (variable value frame)
	        (let
		   ((variables (frame-variables frame))
		    (values (frame-values frame)))
                   (make-frame (cons variable variables) (cons value values)))))
          (exists?
	     (lambda (variable frame)
	        (let
		   ((variables (frame-variables frame)))
		   (variable-in-list? variable variables)))))
         (cond ((exists? variable frame)
	        (insert-variable-value-frame! variable value (purge-variable! variable frame)))
               (else
	        (insert-variable-value-frame! variable value frame))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;	Environment Definition
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define the-empty-environment '())

(define first-frame
   (lambda (environment) (car environment)))

(define enclosing-environment
   (lambda (environment) (cdr environment)))

(define lookup-variable-value
   (lambda (variable environment)
      (cond ((null? environment) (error "Unbound variable--LOOKUP-VARIABLE-VALUE" variable))
            ((variable-in-frame? variable (first-frame environment)) (frame-lookup variable (first-frame environment)))
	    (else (lookup-variable-value variable (enclosing-environment environment))))))

(define extend-environment
   (lambda (variables values base-environment)
      (begin
         (if apply-compound-procedure-debug
            (begin
	       (display "extend-environment: variables....")
	       (display variables)
	       (newline)
	       (display "extend-environment: values....")
	       (display values)
	       (newline))
	    '())
         (if (list? variables)
             (cons (make-frame variables values) base-environment)
	     (cons (make-frame (list variables) (list values)) base-environment)))))

(define set-variable-value!
   (lambda (variable value environment)
      (let
         ((top-frame (first-frame environment)))
	 (cond ((null? environment)
	        (error "Unbound variable--SET-VARIABLE-VALUE!" variable))
               ((variable-in-frame? variable top-frame)
	        (set-car! environment (add-binding-to-frame! variable value top-frame)))
               (else
	        (set-variable-value! variable value (enclosing-environment environment)))))))

(define define-variable!
   (lambda (variable value environment)
      (let
         ((top-frame (first-frame environment)))
	 (begin
	    (set-car! environment (add-binding-to-frame! variable value top-frame))
	    (if define-variable-debug
	       (display environment)
	       '())))))

(define names-in-environment
   (lambda (environment)
      (letrec
         ((unique-list-of-symbols
	     (lambda (list1 list2)
	       (cond ((null? list2) list1)
	             ((not (null? (memq (car list2) list1))) (unique-list-of-symbols list1 (cdr list2)))
		     (else (unique-list-of-symbols (cons (car list2) list1) (cdr list2)))))))
         (cond ((eq? environment the-empty-environment) '())
	       ((eq? (enclosing-environment environment) the-empty-environment) (frame-variables (first-frame environment)))
	       (else (unique-list-of-symbols (frame-variables (first-frame environment)) (names-in-environment (enclosing-environment environment))))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;	Eval Definition
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define local-eval
   (lambda (expression environment)

	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	;;
	;;	Table Definitions
	;;
	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

      (let
         ((operations (make-table)))
      (let
         ((insert! (lambda (key procedure) ((operations 'insert!) key procedure)))
	  (lookup (lambda (key) ((operations 'lookup) key)))

	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	;;
	;;	Readability Definitions
	;;
	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	  (type-tag car)
	  (procedure-type cadr)
	  (procedure-action caddr)

	  (operator car)
	  (operands cdr)

	  (no-operands? null?)
	  (first-operand car)
	  (rest-operands cdr)

	  (tagged-list?
	     (lambda (object tag)
	        (if (pair? object)
		    (eq? (car object) tag)
		    false))))

      (letrec
         ((list-of-values
	     (lambda (expression environment)
	        (begin
		   (if apply-compound-procedure-debug
		       (begin
		          (display "local-eval::list-of-values: expression....")
			  (display expression)
			  (newline))
                       '())
                   (if (no-operands? expression)
		       '()
		       (cons
		          (local-eval (first-operand expression) environment)
			  (list-of-values (rest-operands expression) environment)))))))

	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	;;
	;;	Syntax Procedures
	;;
	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	;;;;;;;;;;;;;;;
	;;
	;;	Syntax procedures are laregly not
	;;	necessary for this version of eval
	;;	since we are assuming that the
	;;	syntax of the procedures is uniform
	;;	with the procedure type-tag appearing
	;;	as the first element in the procedure
	;;	list and identifying the special form
	;;	sufficiently for eval to complete
	;;	processing.
	;;
	;;;;;;;;;;;;;;;

      (letrec
         ((self-evaluating?
	     (lambda (expression)
	        (cond ((number? expression) true)
		      ((string? expression) true)
		      (else false))))

          (keyword?
	     (lambda (expression)
	        (if (lookup (type-tag expression))
		    true
		    false)))

          (application? pair?)

	  (false?
	     (lambda (result)
	        (eq? result #f)))

          (meta-false?
	     (lambda (result)
	        (eq? result (local-eval 'false environment))))

          (true?
	     (lambda (result)
	        (eq? result #t)))

          (meta-true?
	     (lambda (result)
	        (not (meta-false? result)))))

      (letrec

	;;;;;;;;;;;;;;;
	;;
	;;	quote
	;;
	;;;;;;;;;;;;;;;

         ((text-of-quotation
	     (lambda (expression environment)
	        (cadr expression)))

	;;;;;;;;;;;;;;;
	;;
	;;	load
	;;
	;;;;;;;;;;;;;;;

          (load-filename cadr)

          (eval-load-aux
	     (lambda (filename environment)
	        (let
		   ((inport (open-input-file filename)))
                   (letrec
		      ((eval-lines
		          (lambda ()
			     (let
			        ((obj (read inport)))
				(if (eof-object? obj)
				    (close-input-port inport)
				    (begin
				       (local-eval obj environment)
				       (eval-lines)))))))
                      (eval-lines)))))

           (eval-load
	      (lambda (expression environment)
	         (let
		    ((filename (local-eval (load-filename expression) environment)))
		    (begin
		       (eval-load-aux filename environment)
		       'loaded))))

	;;;;;;;;;;;;;;;
	;;
	;;	match
	;;
	;;;;;;;;;;;;;;;

          (make-match-object
	     (lambda (results environment)
	        (list 'matchlist results environment)))

          (all-matches
	     (lambda (mo) (car (cdr mo))))

          (first-match
	     (lambda (mo) (car (car (cdr mo)))))

	  (rest-matches-object
	     (lambda (mo) (make-match-object (cdr (all-matches mo)) (match-object-environment mo))))

          (match-object-environment
	     (lambda (mo) (car (cdr (cdr mo)))))

          (match-object?
	     (lambda (mo) (tagged-list? mo 'matchlist)))

          (no-more-matches?
	     (lambda (mo) (null? (cadr mo))))

          (match-pattern cadr)

	  (contains-as-list?
	     (lambda (sublist mainlist)
	       (letrec
	          ((begins-as-list?
		      (lambda (startlist mainlist)
		         (cond ((null? startlist) true)
			       ((null? mainlist) false)
			       ((eq? (car startlist) (car mainlist)) (begins-as-list? (cdr startlist) (cdr mainlist)))
			       (else false)))))
                  (cond ((null? sublist) true)
		        ((null? mainlist) false)
			((begins-as-list? sublist mainlist) true)
			(else (contains-as-list? sublist (cdr mainlist)))))))

	  (pattern-match?
	     (lambda (pattern aname)
	        (let
		   ((patternlist (string->list (symbol->string pattern)))
		    (anamelist (string->list (symbol->string aname))))
                   (contains-as-list? patternlist anamelist))))

          (eval-match-aux
	     (lambda (pattern namelist)
	        (cond ((null? namelist) '())
		      ((pattern-match? pattern (car namelist)) (cons (car namelist) (eval-match-aux pattern (cdr namelist))))
		      (else (eval-match-aux pattern (cdr namelist))))))

          (eval-match
	     (lambda (expression environment)
	        (if (not (null? (cdr expression)))
	           (let
		      ((pattern (local-eval (match-pattern expression) environment))
		       (namelist (names-in-environment environment)))
                      (make-match-object (eval-match-aux pattern namelist) environment))
                   (let
		      ((namelist (names-in-environment environment)))
		      (make-match-object namelist environment)))))

          (match-object-to-names-data cadr)

          (eval-match-object-to-names
             (lambda (expression environment)
	        (let
	           ((mo (local-eval (match-object-to-names-data expression) environment)))
                   (all-matches mo))))

          (match-object-to-values-data cadr)

          (eval-match-object-to-values
	     (lambda (expression environment)
                (letrec
		   ((eval-match-object-to-values-aux
		       (lambda (mo results)
		          (cond ((no-more-matches? mo) results)
			        (else (cons (local-eval (first-match mo) (match-object-environment mo)) (eval-match-object-to-values-aux (rest-matches-object mo) results)))))))
                   (eval-match-object-to-values-aux (local-eval (match-object-to-values-data expression) environment) '()))))

	;;;;;;;;;;;;;;;
	;;
	;;	assignment
	;;
	;;;;;;;;;;;;;;;

          (assignment-variable cadr)
          (assignment-value caddr)

	  (eval-assignment
	     (lambda (expression environment)
	        (begin
	           (set-variable-value! (assignment-variable expression) (local-eval (assignment-value expression) environment) environment)
		   'affirmative)))

	;;;;;;;;;;;;;;;
	;;
	;;	definition
	;;
	;;;;;;;;;;;;;;;

          (definition-variable
	     (lambda (expression)
	        (begin
	           (if define-function-debug
		       (begin
		          (if (pair? (cadr expression))
			      (begin
			         (display "local-eval::definition-variable: variables....")
				 (display (caadr expression))
				 (newline))
                              '()))
                       '())
                    (if (symbol? (cadr expression))
		       (cadr expression)
		       (caadr expression)))))

          (definition-value
	     (lambda (expression)
	        (begin
	           (if define-function-debug
		       (begin
		          (if (pair? (cadr expression))
			      (begin
			         (display "local-eval::definition-value: value....")
				 (display (make-lambda (cdadr expression) (cddr expression)))
				 (newline))
                              '()))
                       '())
                   (if (symbol? (cadr expression))
		       (caddr expression)
		       (make-lambda (cdadr expression) (cddr expression))))))

          (eval-definition
	     (lambda (expression environment)
	        (begin
	           (if define-function-debug
		       (begin
		          (display "local-eval::eval-definition: expression....")
			  (display expression)
			  (newline))
                       '())
                   (define-variable! (definition-variable expression) (local-eval (definition-value expression) environment) environment)
		   'affirmative)))

	;;;;;;;;;;;;;;;
	;;
	;;	if
	;;
	;;;;;;;;;;;;;;;

          (if-predicate cadr)
          (if-consequent caddr)
          (if-alternative cadddr)
          (make-if
             (lambda (predicate consequent alternative) (list 'if predicate consequent alternative)))

          (eval-if
	     (lambda (expression environment)
	        (if (meta-true? (local-eval (if-predicate expression) environment))
		    (local-eval (if-consequent expression) environment)
		    (local-eval (if-alternative expression) environment))))

	;;;;;;;;;;;;;;;
	;;
	;;	let
	;;
	;;;;;;;;;;;;;;;

          (let-clauses cadr)

          (let-body cddr)

          (let-args car)

          (let-vals cadr)

	  (let-lambda-data
	    (lambda (clauses args vals)
	       (cond ((null? clauses) (list args vals))
	             (else (let-lambda-data (cdr clauses) (cons (car (car clauses)) args) (cons (car (cdr (car clauses))) vals))))))

          (eval-let
	     (lambda (expression environment)
	        (let
		   ((data (let-lambda-data (let-clauses expression) '() '()))
		    (body (let-body expression)))
                   (let
		      ((lexp (cons (make-lambda (let-args data) body) (let-vals data))))
                      (local-eval lexp environment)))))

	;;;;;;;;;;;;;;;
	;;
	;;	letrec
	;;
	;;;;;;;;;;;;;;;

          (letrec-clauses cadr)

          (letrec-body cddr)

	  (letrec-vars
	     (lambda (expression)
	        (letrec
		   ((letrec-vars-aux
		       (lambda (lrlist varlist)
		          (cond ((null? lrlist) varlist)
			        (else (letrec-vars-aux (cdr lrlist) (cons (car (car lrlist)) varlist)))))))
                   (letrec-vars-aux (letrec-clauses expression) '()))))

	  (letrec-exps
	     (lambda (expression)
	        (letrec
		   ((letrec-exps-aux
		       (lambda (lrlist expslist)
		          (cond ((null? lrlist) expslist)
			        (else (letrec-exps-aux (cdr lrlist) (cons (car (cdr (car lrlist))) expslist)))))))
                   (letrec-exps-aux (letrec-clauses expression) '()))))

          (letrec-create-bindings!
	     (lambda (vars exps env)
	        (if (null? vars)
		    '()
		    (begin
		       (define-variable! (car vars) (local-eval (car exps) env) env)
		       (letrec-create-bindings! (cdr vars) (cdr exps) env)))))

          (eval-letrec
	     (lambda (expression environment)
	        (let
		   ((newenv (extend-environment '() '() environment)))
	           (let
		      ((vars (letrec-vars expression))
		       (exps (letrec-exps expression))
		       (body (letrec-body expression)))
                      (begin
		         (letrec-create-bindings! vars exps newenv)
                         (eval-sequence body newenv))))))

	;;;;;;;;;;;;;;;
	;;
	;;	lambda
	;;
	;;;;;;;;;;;;;;;

          (lambda-parameters cadr)

          (lambda-body cddr)

          (make-lambda
	     (lambda (params body)
		(cons 'lambda (cons params body))))

	;;;;;;;;;;;;;;;
	;;
	;;	begin
	;;
	;;;;;;;;;;;;;;;

          (begin-actions cdr)
	  (last-expression?
	     (lambda (expression) (null? (cdr expression))))
          (first-expression car)
          (rest-expressions cdr)
	  (make-begin
	     (lambda (seq) (cons 'begin seq)))

          (eval-sequence
	     (lambda (expression environment)
	        (begin
		   (if apply-compound-procedure-debug
		       (begin
		          (display "local-eval::eval-sequence: expression....")
			  (display expression)
			  (newline))
                       '())
                   (cond ((last-expression? expression) (local-eval (first-expression expression) environment))
		         (else
                            (begin
                               (local-eval (first-expression expression) environment)
			       (eval-sequence (rest-expressions expression) environment)))))))

	;;;;;;;;;;;;;;;
	;;
	;;	cond
	;;
	;;;;;;;;;;;;;;;

          (cond-clauses cdr)
          (cond-predicate car)
          (cond-actions cdr)
	  (cond-else-clause?
	     (lambda (clause) (eq? (cond-predicate clause) 'else)))

          (sequence->expression
	     (lambda (seq)
	        (cond ((null? seq) seq)
		      ((last-expression? seq) (first-expression seq))
		      (else (make-begin seq)))))

          (expand-clauses
	     (lambda (clauses)
	        (if (null? clauses)
		    'false
		    (let
		       ((first (car clauses))
		        (rest (cdr clauses)))
                       (if (cond-else-clause? first)
		           (if (null? rest)
			       (sequence->expression (cond-actions first))
			       (error "ELSE clause is not last--COND->IF" clauses))
                           (make-if
			      (cond-predicate first)
			      (sequence->expression (cond-actions first))
			      (expand-clauses rest)))))))

          (cond->if
	     (lambda (expression) (expand-clauses (cond-clauses expression))))

	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	;;
	;;	Procedure Definitions
	;;
	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	
          (make-procedure
	     (lambda (params body environment) (list 'procedure params body environment)))

          (update-procedure-environment!
	     (lambda (procedure environment)
	        (let
		   ((env-section (cdddr procedure)))
		   (set-car! env-section environment))))

          (compound-procedure?
	     (lambda (procedure) (tagged-list? procedure 'procedure)))

          (procedure-parameters cadr)

          (procedure-body caddr)

          (procedure-environment cadddr)

          (primitive-procedure?
	     (lambda (procedure) (tagged-list? procedure 'primitive)))

          (primitive-implementation
	     (lambda (procedure) (cadr procedure)))

	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	;;
	;;	Apply Definition
	;;
	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

          (map
             (lambda (proc list)
                (if (null? list)
                    '()
	            (cons (proc (car list)) (map proc (cdr list))))))

          (apply-operation cadr)

	  (apply-arguments caddr)

          (local-apply
	     (lambda (procedure arguments environment)
	        (cond ((primitive-procedure? procedure)
		          (let
			     ((result (apply (primitive-implementation procedure) arguments)))
			     (cond ((true? result) (local-eval 'true environment))
			           ((false? result) (local-eval 'false environment))
				   (else result))))
                      ((compound-procedure? procedure)
		          (begin
			     (if apply-compound-procedure-debug
			         (begin
				    (display "local-eval::local-apply: procedure....")
				    (display (procedure-parameters procedure))
				    (display ", ")
				    (display (procedure-body procedure))
				    (newline))
                                 '())
                             (eval-sequence (procedure-body procedure) (extend-environment (procedure-parameters procedure) arguments (procedure-environment procedure)))))
                      ((match-object? procedure) (map (lambda (op) (local-eval (cons op arguments) (match-object-environment procedure))) (all-matches procedure)))
                      (else (error "Unknown procedure type--LOCAL-APPLY" procedure))))))

	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	;;
	;;	Inserts
	;;
	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

         (begin

	    (insert! 'quote text-of-quotation)
	    (insert! 'set! eval-assignment)
	    (insert! 'define eval-definition)
	    (insert! 'if eval-if)
	    (insert! 'let eval-let)
	    (insert! 'letrec eval-letrec)
	    (insert! 'load eval-load)
	    (insert! 'match eval-match)
	    (insert! 'match-object-to-names eval-match-object-to-names)
	    (insert! 'match-object-to-values eval-match-object-to-values)
	    (insert! 'lambda (lambda (expression environment) (make-procedure (lambda-parameters expression) (lambda-body expression) environment)))
	    (insert! 'begin (lambda (expression environment) (eval-sequence (begin-actions expression) environment)))
	    (insert! 'cond (lambda (expression environment) (local-eval (cond->if expression) environment)))
	    (insert! 'apply (lambda (expression environment) (local-apply (local-eval (apply-operation expression) environment) (local-eval (apply-arguments expression) environment) environment)))

	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	;;
	;;	Eval Clauses
	;;
	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

            (if eval-debug
               (begin
                  (write-line "Entering eval classification--EVAL")
                  (write-line))
               '())
            (cond ((self-evaluating? expression)
	              (begin
		         (if eval-debug
			     (write-line "self-evaluating?--LOCAL-EVAL")
			     '())
                         expression))
                  ((symbol? expression)
		      (begin
		         (if eval-debug
			     (write-line "symbol?--LOCAL-EVAL")
			     '())
                         (if (or define-function-debug apply-compound-procedure-debug)
			     (begin
			        (display "local-eval::symbol?: expression....")
				(display expression)
				(newline))
                             '())
                         (lookup-variable-value expression environment)))
                  ((eq? (type-tag expression) 'add-op)
		      (begin
		         (if eval-debug
			     (write-line "add-op--LOCAL-EVAL")
			     '())
                         (insert! (procedure-type expression) (procedure-action expression))))
                  ((keyword? expression)
		      (begin
		         (if eval-debug
			     (write-line "keyword?--LOCAL-EVAL")
			     '())
                         (if define-function-debug
			     (begin
			        (display "local-eval::keyword?: expression....")
				(display expression)
				(newline))
                             '())
                         ((lookup (type-tag expression)) expression environment)))
                  ((application? expression)
		      (begin
		         (if eval-debug
			     (write-line "application?--LOCAL-EVAL")
			     '())
                         (if (or define-function-debug apply-compound-procedure-debug)
			     (begin
			        (display "local-eval::application?: expression....")
				(display expression)
				(newline))
                             '())
                         (let
			    ((op (local-eval (operator expression) environment)))
                             (local-apply op (list-of-values (operands expression) environment) environment))))
                  (else (error "Unknown expression type--LOCAL-EVAL" expression)))))))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;	Environment Configuration
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define map
   (lambda (proc list)
      (if (null? list)
          '()
	  (cons (proc (car list)) (map proc (cdr list))))))

(define primitive-procedures
   (list
      (list 'top-load load)
      (list 'exit exit)
      (list 'car car)
      (list 'cons cons)
      (list 'cdr cdr)
      (list 'null? null?)
      (list '= =)
      (list '< <)
      (list '> >)
      (list '+ +)
      (list '- -)
      (list '* *)
      (list '/ /)))

(define primitive-procedure-names
   (lambda () (map car primitive-procedures)))

(define primitive-procedure-objects
   (lambda ()
      (map (lambda (proc) (list 'primitive (cadr proc))) primitive-procedures)))

(define setup-environment
   (lambda ()
      (let
         ((initial-environment (extend-environment (primitive-procedure-names) (primitive-procedure-objects) the-empty-environment)))
	 (begin
	    (define-variable! 'true #t initial-environment)
	    (define-variable! 'false #f initial-environment)
	    initial-environment))))

(define the-global-environment (setup-environment))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;	DRIVER LOOP
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define input-prompt "Blather-> ")
(define output-prompt "Blather:- ")

(define prompt-for-input
   (lambda (lstring)
      (begin
         (newline)
	 (newline)
	 (display lstring))))

(define announce-output
   (lambda (lstring)
      (begin
         (newline)
	 (display lstring)
	 (newline)
	 (newline))))

(define procedure-parameters cadr)
(define procedure-body caddr)

(define user-print
   (lambda (object)
      (letrec
         ((tagged-list?
	     (lambda (object tag)
	        (if (pair? object)
		    (eq? (car object) tag)
		    false)))
          (compound-procedure?
	     (lambda (procedure)
	        (tagged-list? procedure 'procedure)))
          (match-procedure?
	     (lambda (procedure)
	        (tagged-list? procedure 'matchlist))))
         (cond ((compound-procedure? object)
                   (display (list 'compound-procedure (procedure-parameters object) (procedure-body object) '<procedure-env>)))
               ((match-procedure? object) (display (list 'matchlist (cadr object) '<match-env>)))
               (else (display object))))))

(define driver-loop
   (lambda ()
      (begin
         (prompt-for-input input-prompt)
	 (let
	    ((input (read)))
	    (let
	       ((output (local-eval input the-global-environment)))
	       (begin
	          (if define-function-debug
		      (begin
		         (display "driver-loop: input....")
			 (display input)
			 (newline))
                      '())
                  (announce-output output-prompt)
		  (user-print output))))
         (driver-loop))))

(if run
   (begin
      (newline)
      (display "************************************************************")
      (newline)
      (display "*")
      (newline)
      (display "*	Blather")
      (newline)
      (display "*")
      (newline)
      (display "*	A metacircular evaluator core in R^5 scheme")
      (newline)
      (display "*	for purpose-built evaluators with an extension for")
      (newline)
      (display "*	reflective pattern matching.")
      (newline)
      (display "*")
      (newline)
      (display "*")
      (newline)
      (display "*	By Kulisics, Joseph D.")
      (newline)
      (display "*	2008 April 17")
      (newline)
      (display "*")
      (newline)
      (display "*	Based on the material of \"The Structure and Interpretation of Computer Programs\"")
      (newline)
      (display "*	by Abelson and Sussman")
      (newline)
      (display "*")
      (newline)
      (display "************************************************************")
      (newline)
      (driver-loop))
   '())