[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

eval.scm

I believe the enclosed code implements R5RS' two-argument EVAL for
SLIB-supporting Schemes in terms of one-argument EVAL here named
slib:eval (which can be defined using LOAD).

The environment returned by (INTERACTION-ENVIRONMENT) is mutable.
When EVAL is called with the interaction environment, it restores the
environment stack (EVAL::SAVED-ENVIRONMENTS), evaluates the
expression, and then rebinds the environments in their original order,
capturing top-level binding changes at each step.

     (load "eval.scm")
     => #<unspecified>
     (define car 'volvo)
     => #<unspecified>
     car
     => volvo
     (eval 'car (interaction-environment))
     => volvo
     (eval 'car (scheme-report-environment 5))
     => #<primitive-procedure car>
     (eval '(eval 'car (interaction-environment))
           (scheme-report-environment 5))
     => volvo
     (eval '(eval '(set! car 'buick) (interaction-environment))
           (scheme-report-environment 5))
     => #<unspecified>
     car
     => buick
     (eval 'car (scheme-report-environment 5))
     => #<primitive-procedure car>
     (eval '(eval 'car (interaction-environment))
           (scheme-report-environment 5))
     => buick

Does this EVAL conform to the R5RS proposal?
I thank you for your attention.

			      -=-=-=-=-

; "eval.scm", Eval proposed by Guillermo (Bill) J. Rozas for R5RS.
; Copyright (c) 1997, 1998 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

;;; Rather than worry over the status of all the optional procedures,
;;; just require as many as possible.

(require 'rev4-optional-procedures)
(require 'dynamic-wind)
(require 'transcript)
(require 'with-file)
(require 'values)
(require 'macro)

(define eval::vect-ref vector-ref)
(define eval:make-environment
  (let ((vector vector)
	(null? null?)
	(cons cons)
	(cdr cdr)
	(car car)
	(+ +))
    (lambda (identifiers)
      (vector
       identifiers
       #f
       `(begin
	  ,@(do ((ind 0 (+ 1 ind))
		 (env identifiers (cdr env))
		 (sets '()
		       (cons
			`(set! ,(car env)
			       (eval::vect-ref eval::environment-values ,ind))
			sets)))
		((null? env) sets)))))))

(define eval:capture-environment!
  (let ((list->vector list->vector)
	(vector-set! vector-set!)
	(eval-1 slib:eval))
    (lambda (environment)
      (vector-set!
       environment 1
       (list->vector (eval-1 `((lambda args args)
			       ,@(eval::vect-ref environment 0))))))))

(define eval:copy-environment
  (let ((list->vector list->vector)
	(vector->list vector->list))
    (lambda (environment)
      (list->vector (vector->list environment)))))

(define interaction-environment
  (let ((env (eval:make-environment '())))
    (lambda () env)))

;;; null-environment is set by first call to scheme-report-environment at
;;; the end of this file.
(define null-environment #f)

(define scheme-report-environment
  (let* ((r4rs-procedures
	  (append
	   (cond ((provided? 'inexact)
		  (append
		   '(acos angle asin atan cos exact->inexact exp
			  expt imag-part inexact->exact log magnitude
			  make-polar make-rectangular real-part sin
			  sqrt tan)
		   (if (let ((n (string->number "1/3")))
			 (and (number? n) (exact? n)))
		       '(denominator numerator)
		       '())))
		 (else '()))
	   (cond ((provided? 'rationalize)
		  '(rationalize))
		 (else '()))
	   (cond ((provided? 'delay)
		  '(force))
		 (else '()))
	   (cond ((provided? 'char-ready?)
		  '(char-ready?))
		 (else '()))
	   '(* + - / < <= = > >= abs append apply assoc assq assv boolean?
	       caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar
	       caddar cadddr caddr cadr call-with-current-continuation
	       call-with-input-file call-with-output-file car cdaaar cdaadr
	       cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr
	       cdddr cddr cdr ceiling char->integer char-alphabetic?  char-ci<=?
	       char-ci<?  char-ci=?  char-ci>=?  char-ci>?  char-downcase
	       char-lower-case?  char-numeric?  char-upcase char-upper-case?
	       char-whitespace?  char<=?  char<?  char=?  char>=?  char>?  char?
	       close-input-port close-output-port complex?  cons
	       current-input-port current-output-port display eof-object?  eq?
	       equal?  eqv?  even?  exact?  floor for-each gcd inexact?
	       input-port?  integer->char integer?  lcm length list list->string
	       list->vector list-ref list-tail list?  load make-string
	       make-vector map max member memq memv min modulo negative?
	       newline not null?  number->string number?  odd?  open-input-file
	       open-output-file output-port?  pair?  peek-char positive?
	       procedure?  quotient rational?  read read-char real?  remainder
	       reverse round set-car!  set-cdr!  string string->list
	       string->number string->symbol string-append string-ci<=?
	       string-ci<?  string-ci=?  string-ci>=?  string-ci>?  string-copy
	       string-fill!  string-length string-ref string-set!  string<=?
	       string<?  string=?  string>=?  string>?  string?  substring
	       symbol->string symbol?  transcript-off transcript-on truncate
	       vector vector->list vector-fill!  vector-length vector-ref
	       vector-set!  vector?  with-input-from-file with-output-to-file
	       write write-char zero?
	       )))
	 (r5rs-procedures
	  (append
	   '(call-with-values dynamic-wind eval interaction-environment
			      null-environment scheme-report-environment values)
	   r4rs-procedures))
	 (r4rs-environment (eval:make-environment r4rs-procedures))
	 (r5rs-environment (eval:make-environment r4rs-procedures)))
    (lambda (version)
      (cond ((not (vector-ref r5rs-environment 1))
	     (let ((null-env (eval:make-environment r5rs-procedures)))
	       (vector-set! null-env 1
			    (make-vector (length r5rs-procedures) #f))
	       (set! null-environment (lambda version null-env)))
	     (eval:capture-environment! r4rs-environment)
	     (eval:capture-environment! r5rs-environment)))
      (case version
	((4) r4rs-environment)
	((5) r5rs-environment)
	(else (slib:error 'eval 'version version 'not 'available))))))

(define eval::environment-values #f)
(define eval::saved-environments '())
(define eval
  (let ((dynamic-wind dynamic-wind)
	(vector-ref vector-ref)
	(for-each for-each)
	(eval-1 slib:eval)
	(vector vector)
	(null? null?)
	(cons cons)
	(car car)
	(cdr cdr))
    (define (restore-environment environment)
      (cond (eval::environment-values
	     (slib:error 'eval "environment machinery is broken."))
	    ((null? (vector-ref environment 0)))
	    (else
	     (set! eval::environment-values (vector-ref environment 1))
	     (eval-1 (vector-ref environment 2))
	     (set! eval::environment-values #f))))
    (lambda (expression . environment)
      (cond
       ((null? environment) (eval-1 expression))
       ((eq? (interaction-environment) (car environment))
	(set! environment (car environment))
	(let ((my-saved-environments eval::saved-environments))
	  (dynamic-wind
	   (lambda ()
	     (for-each (lambda (env) (restore-environment (vector-ref env 1)))
		       my-saved-environments)
	     (set! eval::saved-environments '()))
	   (lambda () (eval-1 expression))
	   (lambda ()
	     (for-each (lambda (env)
			 (eval:capture-environment! (vector-ref env 1))
			 (restore-environment (vector-ref env 0)))
		       (reverse my-saved-environments))
	     (set! eval::saved-environments my-saved-environments)))))
       (else
	(set! environment (car environment))
	(dynamic-wind
	 (lambda ()
	   (define save (eval:copy-environment environment))
	   (eval:capture-environment! save)
	   (set! eval::saved-environments
		 (cons (vector environment save) eval::saved-environments))
	   (restore-environment environment))
	 (lambda () (eval-1 expression))
	 (lambda ()
	   (restore-environment (vector-ref (car eval::saved-environments) 1))
	   (set! eval::saved-environments (cdr eval::saved-environments))
	   )))))))
(set! slib:eval eval)

;;; Now that all the R5RS procedures are defined, capture r5rs-environment.
(and (scheme-report-environment 5) #t)