#lang racket
;(require compatibility/mlist)
(require "du-utility.scm")
(provide extend-environment lookup-variable-value setup-environment get-current-keys get-current-locks get-frame get-basic-env)
;
; environment
;
(define (primitive-procedure-names)
  (map car primitive-procedures))

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

(define primitive-procedures
  (list
;  (list (list 'newline newline)
;        (list 'display display)
        ))


(define (extend-environment vars vals base-env)
  (define (make-frame variables values1)
    (map list variables values1))
  (if (= (length vars) (length vals))
          (cons (get-env-extension base-env) 
          	    (cons (make-frame vars vals) (get-basic-env base-env)))
      (if (< (length vars) (length vals))
          (error "Too many arguments supplied -- EXTEND-EVIRONMENT" vars vals)
          (error "Too few arguments supplied -- EXTEND-EVIRONMENT" vars vals))))

(define (search-frame frame-part var)
  (cond ((null? frame-part) #f)
        ((eq? var (get-nb-name (car frame-part))) (car frame-part)) ;nb records
        (else (search-frame (cdr frame-part) var))))

(define (search-environment var xenv)
  (if (eq? (get-basic-env xenv) the-empty-environment)
    #f
    (let ((frame (first-frame xenv)))
      (let ((name-binding-maybe (search-frame frame var)))
        (if name-binding-maybe
          name-binding-maybe
          (search-environment var (enclosing-environment xenv))) ))))

(define (get-frame var xenv)
  (let ((name-binding-maybe (search-frame (first-frame xenv) var)))
    (if name-binding-maybe
      (first-frame xenv)
      (get-frame var (enclosing-environment xenv)) ) ))


(define (lookup-variable-value var xenv)
  (let ((name-binding (search-environment var xenv)))
    (if name-binding
      (cond
       ((compound-procedure? (get-nb-value name-binding))
               (get-nb-value name-binding))
;;        ((get-nb-hiden name-binding)
;;         (error "Hiden variable" var))
       (else
        (get-nb-value name-binding)))
      (error "Unbound variable" var))))


(define (get-basic-env xenv) (cdr xenv))
(define (get-env-extension xenv) (car xenv))
; extension to the environment is in front of env, now (keys and locks)

(define (get-current-keys xenv)
  (list-ref (get-env-extension xenv) 0))
(define (get-current-locks xenv)
  (list-ref (get-env-extension xenv) 1))
(define (get-nb-name nb)
  (list-ref nb 0))
(define (get-nb-value nb)
  (list-ref nb 1))
;; (define (get-nb-hiden nb)
;;   (and (eq? 3 (length nb)) (list-ref nb 2)))
;(define (set-nb-value! nb qw)
;  (set-mcar! (cdr nb) qw))
(define (enclosing-environment xenv)
  (cons (get-env-extension xenv) (cdr (get-basic-env xenv))))

(define (first-frame xenv)
  (if (get-basic-env xenv) (car (get-basic-env xenv)) #f))

(define the-empty-environment '())

(define (setup-environment)
  (let ((initial-env
         (extend-environment (primitive-procedure-names)
                             (primitive-procedure-objects)
                             (cons (list '() '()) ; exended environment
                                   the-empty-environment))))
    initial-env))