; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.


; A little interpreter.

(define (eval form p)
  (eval-forms (list form) p #f))

; Programs

(define (eval-forms forms p file)
  (eval-nodes (scan-forms forms p file)
	      (package->environment p)
	      file))

(define (eval-nodes nodes env file)
  (if (not (null? nodes))
      (run-nodes nodes (bind-source-file-name file env))))

(define (run-nodes nodes env)
  (do ((nodes nodes (cdr nodes)))
      ((null? (cdr nodes))
       (run-node (car nodes) env))
    (run-node (car nodes) env)))

(define (run-node node env)
  (cond ((define-node? node)
	 (let* ((form (node-form node))
		(loc (binding-place (lookup env (cadr form))))
		(value (run (caddr form) env)))
	   (set-location-defined?! loc #t)
	   (set-contents! loc value)))
	((not (define-syntax-node? node))
	 (run node env))))


; Main dispatch for a single expression.

(define (run exp env)
  (let ((node (classify exp env)))
    ((operator-table-ref interpreters (node-operator-id node)) node env)))

(define interpreters
  (make-operator-table (lambda (node env)
			 (run-call (node-form node) env))))

(define (define-interpreter name type proc)
  (operator-define! interpreters name type proc))

(define-interpreter 'name #f
  (lambda (node env)
    (let ((binding (name-node-binding node env)))
      (cond ((binding? binding)
	     (if (and (compatible-types? (binding-type binding) value-type)
		      (location? (binding-place binding)))
		 (let ((loc (binding-place binding)))
		   (if (location-defined? loc)
		       (contents loc)
		       (error "uninitialized variable" (schemify node env))))
		 (error "invalid variable reference" (schemify node env))))
	    ((unbound? binding)
	     (error "unbound variable" (schemify node env)))
	    (else
	     (error "peculiar binding" node binding))))))

(define (name-node-binding node env)
  (or (node-ref node 'binding)
      (lookup env (node-form node))))

(define-interpreter 'literal #f
  (lambda (node env)
    (node-form node)))

(define-interpreter 'call #f
  (lambda (node env)
    (run-call (node-form node) env)))

(define (run-call exp env)
  (let ((proc (run (car exp) env)))	;Doing this first aids debugging
    (apply proc
	   (map (lambda (arg-exp)
		  (run arg-exp env))
		(cdr exp)))))

(define-interpreter 'quote syntax-type
  (lambda (node env)
    (cadr (node-form node))))

(define-interpreter 'lambda syntax-type
  (lambda (node env)
    (let ((exp (node-form node)))
      (make-interpreted-closure (cadr exp) (cddr exp) env))))

(define (make-interpreted-closure formals body env)
  (lambda args
    (run-body body (bind-vars formals args env))))

(define (run-body body env)
  (scan-body
      body
      env
      (lambda (defs exps)
	(if (null? defs)
	    (run-begin exps env)
	    (run-letrec (map (lambda (def) (cdr (node-form def))) defs)
			exps
			env)))))


(define-interpreter 'begin syntax-type
  (lambda (node env)
    (let ((exp (node-form node)))
      (run-begin (cdr exp) env))))

(define (run-begin exp-list env)
  (if (null? exp-list)
      (syntax-error "null begin")
      (let loop ((exp-list exp-list))
	(if (null? (cdr exp-list))
	    (run (car exp-list) env)
	    (begin (run (car exp-list) env)
		   (loop (cdr exp-list)))))))

(define-interpreter 'set! syntax-type
  (lambda (node env)
    (let* ((exp (node-form node))
	   (probe (name-node-binding (classify (cadr exp) env) env)))
      (cond ((and (binding? probe)
		  (location? (cdr probe)))
	     (if (and (location-defined? (binding-place probe))
		      (variable-type? (binding-type probe)))
		 (set-contents! (cdr probe) (run (caddr exp) env))
		 (error "invalid assignment" (schemify node env))))
	    ((unbound? probe) (error "unbound variable" exp))
	    (else (error "peculiar assignment" exp))))))

(define-interpreter 'if syntax-type
  (lambda (node env)
    (let ((exp (node-form node)))
      (if (null? (cdddr exp))
	  (if (run (cadr exp) env)
	      (run (caddr exp) env))	;hack
	  (if (run (cadr exp) env)
	      (run (caddr exp) env)
	      (run (cadddr exp) env))))))

; (reverse specs) in order to try to catch unportabilities

(define-interpreter 'letrec syntax-type
  (lambda (node env)
    (let ((exp (node-form node)))
      (run-letrec (cadr exp) (cddr exp) env))))

(define (run-letrec specs body env)
  (let* ((bindings (map (lambda (spec)
			  (make-binding usual-variable-type
					(make-undefined-location (car spec))
					#f))
			specs))
	 (env (bind (map car specs)
		    bindings
		    env)))
    (for-each (lambda (binding val)
		(let ((loc (binding-place binding)))
		  (set-location-defined?! loc #t)
		  (set-contents! loc val)))
	      bindings
	      (map (lambda (spec) (run (cadr spec) env)) specs))
    (run-body body env)))


(let ((bad (lambda (node env)
	     (error "not valid in expression context" (node-form node)))))
  (define-interpreter 'define syntax-type bad)
  (define-interpreter 'define-syntax syntax-type bad))


; Primitive procedures

(define-interpreter 'primitive-procedure syntax-type
  (lambda (node env)
    (let ((name (cadr (node-form node))))
      (or (table-ref primitive-procedures name)
	  (lambda args
	    (error "unimplemented primitive procedure" name))))))

(define primitive-procedures (make-table))

(define (define-a-primitive name proc)
  (table-set! primitive-procedures name proc)
  (define-interpreter name any-procedure-type
    (lambda (node env)
      (apply proc (map (lambda (arg) (run arg env))
		       (cdr (node-form node)))))))

(define-a-primitive 'unspecific
  (lambda () (if #f #f)))		;For COND

(define-syntax define-some-primitives
  (syntax-rules ()
    ((define-some-primitives name ...)
     (begin (define-a-primitive 'name name) ...))))

(define-some-primitives
  + - * quotient remainder = <
  eq? car cdr cons
  pair?
  vector? vector-ref string? string-ref
  symbol?
  char<? char=?)


; --------------------
; Environments

(define (bind-var name arg env)
  (let ((loc (make-undefined-location name)))
    (set-location-defined?! loc #t)
    (set-contents! loc arg)
    (bind1 name (make-binding usual-variable-type loc #f) env)))

(define (bind-vars names args env)
  (cond ((null? names)
	 (if (null? args)
	     env
	     (error "too many arguments" args)))
	((not (pair? names))
	 (bind-var names args env))
	((null? args)
	 (error "too few arguments" names))
	(else
	 (bind-var (car names) (car args)
		   (bind-vars (cdr names) (cdr args) env)))))


; LOAD

(define (load filename . package-option)
  (load-into filename (if (null? package-option)
			  (interaction-environment)
			  (car package-option))))

(define (load-into filename package)
  (eval-nodes (scan-file filename package)
	      (package->environment package)
	      filename))

(define (load-quietly from package)			; No noise. For scsh.
  (display from)
  (if (string? from)
      (eval-nodes (really-scan-file from package #f)
		  (package->environment package)
		  from)
      (eval-nodes (really-scan-port from package)
		  (package->environment package)
		  #f)))

(define (eval-from-file forms p file)	;Scheme 48 internal thing
  (eval-forms forms p file))


; (scan-structures (list s) (lambda (p) #t) (lambda (stuff) #f))
