(load "/u/c311/ss/env.ss")


;;; A version of the <proc-language> that inherits directly from the
;;; <env-language> rather than the <let-language>.

(define <proc-language>
  (class ()
    (base <env-language>)
    (base-inst-vars
      <extended-environment>
      test-clauses)
    (base-methods (base-parse parse))
    (base-init)
    (inst-vars
      (define <closure> ;inst-var definition
	(class (formals body env)
	  (base <procedure>)
	  (inst-vars formals body env)
	  (methods
	    (define apply ;method definition
	      (method (args)
		(eval body (<extended-environment>
			     env
			     formals
			     args)))))))
      (define <proc> ;inst-var definition
	(class (formals body)
	  (base <syntax>)
	  (inst-vars formals body)
	  (methods
	    (define eval ;method definition
	      (method (env)
		(<closure> formals body env)))
	    (define unparse ;method definition
	      (method ()
		(list
		  'proc
		  formals
		  (unparse body)))))))
      (set! test-clauses ;redefiniton of test-clauses
	(append
	  '((((proc (x) x) 3) 3)
	    (((proc (x y) (+ x y)) 1 2) 3)
	    ((((proc (x) (proc (y) (+ x y))) 3) 4) 7))
	  test-clauses)))
    (methods ;methods for <proc-language>
      (define name
	(method () 'proc))
      (define parse
	(method (datum)
	  (form-case datum
	    (proc (formals body)
	      (<proc> formals (parse this body)))
	    (else (base-parse this datum))))))))



;;; A version of the <let-language> that inherits from
;;; <proc-language> and does a "parse-time" transformation
;;; of the let syntax into a procedure application.

(define <let-language>
  (class ()
    (base <proc-language>)
    (base-inst-vars <proc> <call> <exps> test-clauses)
    (base-methods (base-parse parse))
    (base-init)
    (inst-vars
      (set! test-clauses ;redefiniton of test-clauses
	(append
	  '(((let ((x 3) (y 4)) (+ x y)) 7)
	    ((let ((x 1)) 4) 4)
	    ((let ((plus (proc (x y) (+ x y)))) (plus 1 2)) 3))
	  test-clauses)))
    (methods
      (define name
	(method () 'let))
      (define parse
	(method (datum)
	  (form-case datum
	    (let (decls body)
	      (<call>
		(<proc>
		  (map car decls)    ;formals of <proc>
		  (parse this body)) ;body of <proc>
		(<exps> (map
			  (lambda (dat) (parse this dat))
			  (map cadr decls)))))
	    (else
	      (base-parse this datum))))))))





;;; A version of <assign-language> that inherits from
;;; the <let-language> but does not use cells.


(define <assign-language>
  (class ()
    (base <let-language>)
    (base-inst-vars
      <extended-environment>
      initial-environment
      empty-environment
      test-clauses)
    (base-methods (base-parse parse))
    (base-init)
    (inst-vars
      (define <assign>
	(class (var exp)
	  (base <syntax>)
	  (inst-vars var exp)
	  (methods
	    (define eval
	      (method (env)
		(store env var (eval exp env))))
	    (define unparse
	      (method ()
		(list 'assign var (unparse exp)))))))
      (set! <extended-environment>
	(class (env names values)
	  (base <extended-environment>)
	  (public store)
	  (base-inst-vars env names values-vector names-length)
	  (base-init env names values)
	  (methods
	    (define store
	      (method (name value)
		(let ((x (memq name names)))
		  (if x
		    (vector-set! values-vector
		      (- names-length (length x))
		      value)
		    (store env name value))))))))
      (set! initial-environment
	(let ((init-env-names-list (domain initial-environment)))
	  (<extended-environment>
	    empty-environment
	    init-env-names-list
	    (map
	      (lambda (name)
		(apply initial-environment name))
	      init-env-names-list)))))
    (methods
      (define name
	(method () 'assign))
      (define parse
	(method (datum)
	  (form-case datum
	    (assign (name exp)
	      (<assign> name (parse this exp)))
	    (else (base-parse this datum))))))))






;;; A version of the <begin-language> that inherits from the
;;; <assign-language> and use the 2 way begin.

(define <begin-language>
  (class ()
    (base <assign-language>)
    (base-inst-vars test-clauses)
    (base-methods (base-parse parse))    
    (base-init)
    (inst-vars
      (define <begin2>
	(class (exp1 exp2)
	  (base <syntax>)
	  (inst-vars exp1 exp2)
	  (methods
	    (define eval
	      (method (env)
		(eval exp1 env)
		(eval exp2 env)))
	    (define unparse
	      (method ()
		(list 'begin2 (unparse exp1) (unparse exp2)))))))
      (set! test-clauses
	(append
	  '(((begin 1) 1)
	    ((begin 2 3) 3)
	    ((begin 1 2 3) 3))
	  test-clauses)))
    (methods
      (define name
	(method () 'begin))
      (define parse
	(method (datum)
	  (form-case datum
	    (begin (exp . exps)
	      (if (null? exps)
		(parse this exp)
		(<begin2> (parse this exp)
		  (parse this (cons 'begin exps)))))
	    (else (base-parse this datum))))))))