env.ss.other

(define primitive-procedure-names '(break else car + - * add1 sub1 cons = / zero? not and < <= > >= cdr list null? eq? equal? atom? length list->vector list? pair? procedure? vector->list vector make-vector vector-ref vector? number? symbol? set-car! set-cdr! vector-set! caar cddr cadr cdar caaar caadr cadar cdaar caddr cdadr cddar cdddr apply assq assv append map member max void))

(define empty-env
	(lambda ()
	    '()
	)
)

(define extend-env
	(lambda (syms vals env)
		(cons (cons syms (list->vector vals)) env)
	)
)

(define apply-env
  	(lambda (env sym)
	    (if (null? env)
			(apply-global-env sym)
			(let ([syms (caar env)]
			      [vals (cdar env)]
			      [env (cdr env)])
				(let ((pos (list-find-position sym syms)))
				    (if (number? pos)
					(vector-ref vals pos)
					(apply-env env sym)))
			)
		)
 	)
)

(define extend-env-recur
  (lambda (syms vals env)
    (let* ([vec (list->vector vals)]
	   [new-env (cons (cons syms vec) env)])
      (for-each (lambda (item pos)
		  (if (proc? item)
		      (vector-set! vec
				   pos
				   (cases proc item
					  [closure (ids bodies toss-env)
						   (closure ids bodies new-env)]
					  [primitive (id)
						     item]))))
		vals
		(make-indices (- (length vals) 1) '()))
      new-env)))

(define make-indices
  (lambda (n accu)
    (if (= n 0)
	(cons 0 accu)
	(make-indices (- n 1) (cons n accu)))))

(define change-env
	(lambda (env sym val)
	    (if (null? env)
			(change-global-env sym val)
			(let ([syms (caar env)]
			      [vals (cdar env)]
			      [env (cdr env)])
			  	(let ([pos (list-find-position sym syms)])
				    (if (number? pos)
						(vector-set! vals pos val)
						(change-env env sym val)
					)
				)
			)
		)
	)
)

(define list-find-position
  (lambda (sym los)
    (list-index (lambda (sym1) (eqv? sym1 sym)) los)))

(define list-index
  (lambda (pred ls)
    (cond
     ((null? ls) #f)
     ((pred (car ls)) 0)
     (else (let ((list-index-r (list-index pred (cdr ls))))
	     (if (number? list-index-r)
		 (+ list-index-r 1)
		 #f))))))

(define change-global-env
	(lambda (sym body)
		(if (assv sym global-env)
			(set-cdr! (assv sym global-env) (list body))
			(set! global-env (append (list (list sym body)) global-env))
		)
	)
)

(define apply-global-env
	(lambda (sym)
		(if (assv sym global-env)
			(cadr (assv sym global-env))
		)
		
	)
)
(define global-env
	'()
)

(define reset-global-env
	(lambda ()
		(set! global-env
			(map (lambda (x) (list x (primitive x))) primitive-procedure-names)
		)
	)
)
(reset-global-env)