(declare (usual-integrations))

;;; Evaluator data structures for Chapter 4

(define (true? x) (not (eq? x #f)))

(define (false? x) (eq? x #f))

(define the-unspecified-value (list 'the-unspecified-value))

;;; Primitive procedures are inherited from Scheme.

(define primitive-procedure? procedure?)
(define apply-primitive-procedure apply)

;;; Compound procedures

(define (make-procedure parameters body env)
  (list 'procedure parameters body env))

(define (compound-procedure? exp)
  (tagged-list? exp 'procedure))

(define (procedure-parameters p) (list-ref p 1))
(define (procedure-body p) (list-ref p 2))
(define (procedure-environment p) (list-ref p 3))

;;;procedures with declarations are used with the
;;;cbn interpreter
(define (make-procedure-with-declarations vars bproc env)
  (list 'procedure-with-declarations vars bproc env))

(define (procedure-with-declarations? obj)
  (tagged-list? obj
		'procedure-with-declarations))

;;; An ENVIRONMENT is a chain of FRAMES.
(define (environment-parent env)
  (cdr env))

(define (first-frame env) (car env))

(define the-empty-environment '())

(define (environment-variables env)
  (car (first-frame env)))

(define (environment-values env)
  (cdr (first-frame env)))

(define (extend-environment variables values base-environment)
  (if (= (length variables) (length values))
      (cons (cons variables values) base-environment)
      (if (< (length variables) (length values))
          (error "Too many arguments supplied" variables values)
          (error "Too few arguments supplied" variables values))))


;;;;;NOTE!!!  In the initial implementation in the book, we should
;;;;;give an unbound variable error if we run off the end.


(define (lookup-variable-value var env)
  (define (parent-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
	     (parent-loop (cdr env)))
	    ((eq? var (car vars))
	     (car vals))
	    (else
	     (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
	(lookup-scheme-value var)
	(scan (caar env) (cdar env))))
  (parent-loop env))

(define (set-variable-value! var val env)
  (define (parent-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
	     (parent-loop (cdr env)))
	    ((eq? var (car vars))
	     (set-car! vals val)
	     the-unspecified-value)
	    (else
	     (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
	(error "Unbound variable -- SET!" var)
	(scan (caar env) (cdar env))))
  (parent-loop env))

(define (define-variable! var val env)
  (define (scan vars vals)
    (cond ((null? vars)
	   (set-car! (car env) (cons var (caar env)))
	   (set-cdr! (car env) (cons val (cdar env))))
	  ((eq? var (car vars))
	   (set-car! vals val)
	   the-unspecified-value)
	  (else
	   (scan (cdr vars) (cdr vals)))))
  (if (eq? env the-empty-environment)
      (error "Unbound variable -- DEFINE" var) ;should not happen.
      (scan (caar env) (cdar env))))


;;; We speed up Scheme variable lookup by keeping
;;; a cache of the variables that we actually look up.

(define lexical-unreferenceable?
  (make-primitive-procedure 'lexical-unreferenceable?))

(define lexical-reference
  (make-primitive-procedure 'lexical-reference))

(define scheme-variable-cache '())

(define (lookup-scheme-value var)
  (let ((vcell (assq var scheme-variable-cache)))
    (cond (vcell (cdr vcell))
	  ((not (lexical-unreferenceable? user-initial-environment var))
	   (let ((val (lexical-reference user-initial-environment var)))
	     (set! scheme-variable-cache
		   (cons (cons var val) scheme-variable-cache))
	     val))
	  (else
	   (error "Unbound variable" var)))))


;;;This is to keep the Scheme printer from going into an infinite loop
;;;if you try to print a circular data structure, such as an environment

(set! *unparser-list-depth-limit* 10)
(set! *unparser-list-breadth-limit* 10)


;;; useful timer procedure:
;;; sample use is:
;;;         (timed m-eval '(fact 10) the-global-environment)

(define (timed f . args)
  (let ((init (runtime)))
    (let ((v (apply f args)))
      (write-line (list 'time: (- (runtime) init)))
      v)))