[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)
- Follow-Ups:
- Re: eval.scm
- From: Richard Kelsey <kelsey@research.nj.nec.com>