diff options
Diffstat (limited to 'eval.scm')
| -rw-r--r-- | eval.scm | 146 |
1 files changed, 146 insertions, 0 deletions
diff --git a/eval.scm b/eval.scm new file mode 100644 index 0000000..cc4b816 --- /dev/null +++ b/eval.scm @@ -0,0 +1,146 @@ +; "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) + +(define eval:make-environment + (let ((eval-1 slib:eval)) + (lambda (identifiers) + ((lambda args args) + #f + identifiers + (lambda (expression) + (eval-1 `(lambda ,identifiers ,expression))))))) + +(define eval:capture-environment! + (let ((set-car! set-car!) + (eval-1 slib:eval) + (apply apply)) + (lambda (environment) + (set-car! + environment + (apply (lambda (environment-values identifiers procedure) + (eval-1 `((lambda args args) ,@identifiers))) + 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))) + (let ((car car)) + (lambda (version) + (cond ((car r5rs-environment)) + (else + (let ((null-env (eval:make-environment r5rs-procedures))) + (set-car! null-env (map (lambda (i) #f) r5rs-procedures)) + (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 + (let ((eval-1 slib:eval) + (apply apply) + (null? null?) + (eq? eq?)) + (lambda (expression . environment) + (if (null? environment) (eval-1 expression) + (apply + (lambda (environment) + (if (eq? (interaction-environment) environment) (eval-1 expression) + (apply (lambda (environment-values identifiers procedure) + (apply (procedure expression) environment-values)) + environment))) + environment))))) +(set! slib:eval eval) + +;;; Now that all the R5RS procedures are defined, capture r5rs-environment. +(and (scheme-report-environment 5) #t) |