;;;;
;;;; env.stk                            -- R5RS environments
;;;;
;;;; Copyright © 2006-2022 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@essi.fr]
;;;;    Creation date: 29-Nov-2006 22:33 (eg)
;;;;

;;=============================================================================
;;      environment ...
;;=============================================================================
#|
<doc R7RS environment
 * (environment set1 ...)
 *
 * This procedure returns a specifier for the environment that
 * results by starting with an empty environment and then
 * importing each *set*, considered as an import
 * set, into it. The bindings of the environment represented by
 * the specifier, as is the environment itself.
 *
 * In STklos,
 * - each |set| argument can be a list (specifying an R7RS
 *   library) or a symbol (specifying a module).
 * - the return environment is an R7RS library (which can be
 *   passed to |eval|).
 *
 * @lisp
 * (eval '(* 7 3) (environment '(scheme base)))    => 21
 *
 * (let ((f (eval '(lambda (f x) (f x x))
 *                (null-environment 5))))
 *   (f + 10))                                     => 20
 *
 * (eval '(define foo 32)
 *       (environment '(scheme base)))             => errror
 *
 * (let ((e (environment '(only (scheme base) + -)
 *                       '(only (scheme write) display))))
 *   (length (module-symbols e)))                  => 3
 *
 * (let ((e (environment '(prefix (only (scheme base) car)
 *                                foo-))))
 *    (module-symbols e))                            => (foo-car)
 *
 * @end lisp
doc>
|#
(define (environment . args)
  (if (null? args)
      (null-environment)
      (let ((e (%make-empty-environment)))
        ;; import the specified import sets in args
        (%%import e args)
        ;; make the module immutable
        (module-immutable! e)
        e)))


;;=============================================================================
;;      interaction-environment ...
;;=============================================================================
#|
<doc interaction-environment
 * (interaction-environment)
 *
 * This procedure returns the environment in the expression are
 * evaluated by default (the {{stklos}} module). The returned environment
 * is mutable.
doc>
|#
(define (interaction-environment)
  (find-module 'STklos))


;;=============================================================================
;;      null-environment ...
;;=============================================================================
#|
<doc null-environment
 * (null-environment)
 * (null-environment version)
 *
 * Returns a specifier for an environment that is empty except for
 * the (syntactic) bindings for all syntactic keywords defined in
 * the R5RS report.
 *
 * NOTE: In STklos, |null-environment| function can be called
 * without the version number (defaults to 5).
doc>
|#
(define null-environment
  (let ((null-env #f))
    (lambda (:optional (version 5))
      (unless (eq? version 5)
        (error "this version is not supported ~S" version))
      (unless null-env
        (set! null-env (%make-empty-environment))
        (module-immutable! null-env))
      null-env)))

;;=============================================================================
;;      scheme-report-environment ...
;;=============================================================================
(define-module R5RS
  (import (only SCHEME
                * + - / < <= = > >= abs acos append apply asin assoc
                assq assv atan boolean? caar cadr call-with-current-continuation
                call-with-input-file call-with-output-file call-with-values
                call/cc car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
                cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr
                caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar
                cddddr ceiling char->integer char-alphabetic? char-ci<=?
                char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase
                char-lower-case? char-numeric? char-ready? char-upcase
                char-upper-case? char-whitespace? char<=? char<? char=? char>=?
                char>? char? close-input-port close-output-port complex? cons cos
                current-input-port current-output-port denominator display
                dynamic-wind eof-object? eq? equal? eqv? error even?
                exact->inexact exact? exp expt floor for-each force gcd imag-part
                inexact->exact inexact? input-port? integer->char integer? lcm
                length list list->string list->vector list-ref list-tail list?
                load log magnitude make-polar make-rectangular make-string
                make-vector map max member memq memv min modulo negative? newline
                not null? number->string number? numerator odd? open-input-file
                open-output-file output-port? pair? peek-char positive?
                procedure? quotient rational? rationalize read read-char
                real-part real? remainder reverse round set-car! set-cdr! sin
                sqrt 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? tan truncate values
                vector vector->list vector-fill! vector-length vector-ref
                vector-set! vector? with-input-from-file with-output-to-file
                write write-char zero?))

  (export * + - / < <= = > >= abs acos append apply asin assoc
          assq assv atan boolean? caar cadr call-with-current-continuation
          call-with-input-file call-with-output-file call-with-values
          call/cc car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
          cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr
          caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar
          cddddr ceiling char->integer char-alphabetic? char-ci<=?
          char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase
          char-lower-case? char-numeric? char-ready? char-upcase
          char-upper-case? char-whitespace? char<=? char<? char=? char>=?
          char>? char? close-input-port close-output-port complex? cons cos
          current-input-port current-output-port denominator display
          dynamic-wind eof-object? eq? equal? eqv? error even?
          exact->inexact exact? exp expt floor for-each force gcd imag-part
          inexact->exact inexact? input-port? integer->char integer? lcm
          length list list->string list->vector list-ref list-tail list?
          load log magnitude make-polar make-rectangular make-string
          make-vector map max member memq memv min modulo negative? newline
          not null? number->string number? numerator odd? open-input-file
          open-output-file output-port? pair? peek-char positive?
          procedure? quotient rational? rationalize read read-char
          real-part real? remainder reverse round set-car! set-cdr! sin
          sqrt 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? tan truncate values
          vector vector->list vector-fill! vector-length vector-ref
          vector-set! vector? with-input-from-file with-output-to-file
          write write-char zero?))

;; make the R5RS module immutable
(module-immutable! (find-module 'R5RS))


#|
<doc scheme-report-environment
 * (scheme-report-environment)
 * (scheme-report-environment version)
 *
 * Returns a specifier for an environment that contains the bindings defined
 * in the R5RS report.
 *
 * NOTE: In STklos, |scheme-report-environment| function can be called
 * without the version number (defaults to 5).
doc>
|#
(define (scheme-report-environment :optional (version 5))
  (unless (eq? version 5)
    (error "this version is not supported ~S" version))
  (find-module 'R5RS))


(provide "env")
