;;; aux.ss

(program-syntax-for-inst-vars-and-methods #t)

;;; "type" classes

(define <cell>
  (class (value)
    (public store fetch)
    (inst-vars value)
    (methods
      (define fetch
	(method ()
	  value))
      (define store
	(method (new-value)
	  (set! value new-value)))
      (define print
	(method ()
	  (printf "#<cell ~s>" value))))))

(define <procedure>
  (class ()
    (public apply)
    (methods
      (define apply)
      (define print
	(method ()
	  (printf "#<procedure instance>"))))))

(define <environment>
  (class ()
    (base <procedure>)
    (public domain range)
    (base-methods apply)
    (methods
      (define domain)
      (define range
	(method ()
	  (map (lambda (name) (apply this name))
	    (domain this))))
      (define print
	(method ()
	  (printf "#<environment ~s>"
	    (map cons (domain this) (range this))))))))

(define <syntax>
  (class ()
    (public eval print)
    (methods
      (define eval)
      (define unparse)
      (define print
	(method ()
	  (printf "#<syntax ~s>" (unparse this)))))))

(define test-case 'none)

(define test-language 'none)

(define <language>
  (class ()
    (public evaluate name read-eval-print parse test)
    (inst-vars
      (define test-clauses '()))
    (methods
      (define evaluate)
      (define parse)
      (define name)
      (define print
	(method ()
	  (printf "#<language ~a>" (name this))))
      (define read-eval-print
	(method ()
	  (display (name this))
	  (display "> ")
	  (write (evaluate this (read)))
	  (newline)
	  (read-eval-print this)))
      (define test
	(method ()
	  (set! test-language (name this))
	  (for-each (lambda (clause)
		      (set! test-case (car clause))
		      (let ((correct (cadr clause))
			    (answer (evaluate this test-case)))
			(if (not (equal? correct answer))
			  (error 'test "In ~a language, ~s is ~s, not ~s"
			    test-language
			    test-case
			    answer
			    correct))))
	    test-clauses))))))


;;; universal generics

(define print (generic print))

(define eval (generic eval))

(define apply
  (lambda args
    (if (procedure? (car args)) 
      (#%apply #%apply args) ; Chez Scheme's #%apply is the original apply
      (#%apply (generic apply) args))))

(define store (generic store))

(define fetch (generic fetch))

(define domain (generic domain))


;;; for testing

(define language 'none)

(define use
  (lambda (<language-class>)
    (set! language (<language-class>))
    ((generic test) language)))

(define run
  (lambda (datum)
    ((generic evaluate) language datum)))

(define rep
  (lambda ()
    ((generic read-eval-print) language)))

(define ptest
  (lambda (datum)
    (print ((generic parse) language datum))
    (newline)))