(library (rnrs r5rs (6))
(export null-environment scheme-report-environment delay force
exact->inexact inexact->exact quotient remainder modulo)
(import (only (core primitives) exact->inexact inexact->exact quotient remainder modulo)
(rnrs eval)
(rnrs base)
(rnrs control))
(define scheme-report-environment
(let ((r5rs-env
(environment
'(except (rnrs base)
_ letrec* let-values let*-values
real-valued? rational-valued? integer-valued? exact inexact finite? infinite?
nan? div mod div-and-mod div0 mod0 div0-and-mod0 exact-integer-sqrt boolean=?
symbol=? string-for-each vector-map vector-for-each error assertion-violation
call/cc)
'(only (rnrs eval) eval)
'(only (rnrs control) do)
'(only (rnrs lists) assoc assv assq)
'(only (rnrs io simple)
call-with-input-file call-with-output-file
close-input-port close-output-port current-input-port current-output-port
display eof-object? newline open-input-file open-output-file peek-char
read read-char with-input-from-file with-output-to-file write write-char)
'(only (rnrs unicode)
char-upcase char-downcase char-ci=? char-ci<? char-ci>?
char-ci<=? char-ci>=? char-alphabetic? char-numeric? char-whitespace?
char-upper-case? char-lower-case? string-ci=? string-ci<? string-ci>?
string-ci<=? string-ci>=?)
'(only (rnrs mutable-pairs) set-car! set-cdr!)
'(only (rnrs lists) assoc assv assq member memv memq)
'(only (rnrs mutable-strings) string-set! string-fill!)
'(rnrs r5rs))))
(lambda (n)
(unless (= n 5)
(assertion-violation 'scheme-report-environment "Argument should be 5" n))
r5rs-env)))
(define null-environment
(let ((null-env
(environment '(only (rnrs base)
begin if lambda quote set! and or
define define-syntax let-syntax letrec-syntax
let let* letrec
case cond else =>
quasiquote unquote unquote-splicing
syntax-rules ...)
'(only (rnrs control) do))))
(lambda (n)
(unless (= n 5)
(assertion-violation 'scheme-report-environment "Argument should be 5" n))
null-env)))
(define force
(lambda (object)
(object)))
(define-syntax delay
(syntax-rules ()
((delay expression)
(make-promise (lambda () expression)))))
(define make-promise
(lambda (proc)
(let ((result-ready? #f)
(result #f))
(lambda ()
(if result-ready?
result
(let ((x (proc)))
(if result-ready?
result
(begin (set! result-ready? #t)
(set! result x)
result))))))))
)