;;;; environments.scm - User-defined evaluation environments - felix
;
; Copyright (c) 2000-2003, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer.
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution.
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.
;
; Send bugs, suggestions and ideas to:
;
; felix@call-with-current-continuation.org
;
; Felix L. Winkelmann
; Steinweg 1A
; 37130 Gleichen, OT Weissenborn
; Germany

(declare
  (usual-integrations)
  (disable-interrupts)
  (fixnum)
  (inline)
  (no-bound-checks)
  (no-procedure-checks)
  (import ;Not required but nice to know
    ##sys#arbitrary-unbound-symbol
    ##sys#slot
    ##sys#setslot
    ##sys#make-vector
    ##sys#size
    ##sys#error-hook
    ##sys#hash-table-location
    ##sys#structure?
    ##sys#walk-namespace
    ##sys#make-structure
    ##sys#check-structure
    ##sys#check-list
    ##sys#copy-env-table
    ##sys#check-symbol
    ##sys#not-a-proper-list-error
    ##sys#hash-table-for-each
    ##sys#environment-symbols)
  (bound-to-procedure
    ##sys#slot
    ##sys#setslot
    ##sys#make-vector
    ##sys#size
    ##sys#error-hook
    ##sys#hash-table-location
    ##sys#structure?
    ##sys#walk-namespace
    ##sys#make-structure
    ##sys#check-structure
    ##sys#check-list
    ##sys#copy-env-table
    ##sys#check-symbol
    ##sys#not-a-proper-list-error
    ##sys#hash-table-for-each
    ##sys#environment-symbols)
  (export
    make-environment
    environment?
    environment-copy
    environment-ref
    environment-set!
    environment-extend!
    environment-includes?
    environment-set-mutable!
    environment-mutable?
    environment-extendable?
    environment-has-binding?
    environment-remove!
    environment-for-each
    environment-symbols) )

;;;

(define UNBOUND-VALUE (##sys#slot '##sys#arbitrary-unbound-symbol 0))

(define-constant DEFAULT-ENVIRONMENT-TABLE-SIZE 301)

(define-constant ERROR-CODE/TYPE/LIST 19)

;;;

(define-inline (->boolean obj)
  (and obj #t) )

(define (error/undefined-symbol loc env sym)
  (error loc "symbol undefined in environment" sym env) )

(define (error/type/list loc obj)
  (##sys#error-hook ERROR-CODE/TYPE/LIST loc obj) )

(define (error/inextensible-environment loc env)
  (error loc "inextensible environment" env) )

#; ;UNUSED
(define (error/immutable-symbol loc sym env)
  (error loc "symbol immutable in environment" sym env) )

(define-inline (unbound-value? obj)
  (eq? UNBOUND-VALUE obj) )

(define-inline (%symbol-binding sym)
  (##sys#slot sym 0) )

(define-inline (%symbol-bind! sym val)
  (##sys#setslot sym 0 val) )

(define-inline (%environment-table env)
  (##sys#slot env 1) )

(define-inline (%environment-extensible? env)
  (##sys#slot env 2) )

(define-inline (%environment-location-binding eloc)
  (##sys#slot eloc 1) )

(define-inline (%environment-location-bind! eloc val)
  (##sys#setslot eloc 1 val) )

(define-inline (%environment-location-mutable? eloc)
  (##sys#slot eloc 2) )

(define-inline (%environment-location-mutable-set! eloc flag)
  (##sys#setslot eloc 2 flag) )

#; ;UNUSED
(define (%environment-location-bind!/mutable? eloc val loc sym env)
  ;Created symbols are always mutable
  (if (%environment-location-mutable? eloc)
      (%environment-location-bind! eloc val)
      (error/immutable-symbol loc sym env)) )

(define-inline (%make-environment-table/size siz)
  (##sys#make-vector siz '()) )

(define-inline (%make-environment-table)
  (%make-environment-table/size DEFAULT-ENVIRONMENT-TABLE-SIZE) )

;Enough to distinguish interaction-environment but not a general test.
(define-inline (%environment-table? et)
  et )

(define-inline (%environment-table-size et)
  (##sys#size et) )

(define-inline (%environment-table-ref et i)
  (##sys#slot et i) )

(define-inline (%environment-table-set! et i v)
  (##sys#setslot et i v) )

(define-inline (%environment-location et sym extd-flag)
  (##sys#hash-table-location et sym extd-flag) )

(define-inline (%environment-location/exist? et sym loc)
  (or (%environment-location et sym #f)
      (error/undefined-symbol loc env sym)) )

(define-inline (%make-environment-table-setter et)
  (lambda (sym)
    (%environment-location-bind!
      (%environment-location et sym #t)
      (%symbol-binding sym)) ) )

;;;

;;

(define (make-environment #!optional extendable-flag)
  (##sys#make-structure 'environment
                        (%make-environment-table) extendable-flag) )

;;

(define (environment? obj)
  (##sys#structure? obj 'environment) )

;;

(define (environment-copy env . mf+syms)
  (##sys#check-structure env 'environment 'environment-copy)
  (let ([mff (pair? mf+syms)])
    (let-optionals mf+syms ([mf #f] [syms #f])
      (when syms (##sys#check-list syms 'environment-copy))
      (let ([et (%environment-table env)] )
        (unless (%environment-table? et) ;interaction-environment?
          ;Use a snapshot of the existing symbol table
          ;as the basis for the new environment table.
          ;FIXME enumerates the same set of symbols twice.
          (set! et (%make-environment-table))
          (let ([addsym (%make-environment-table-setter et)])
            (##sys#walk-namespace addsym) ) )
        (##sys#make-structure 'environment
          (##sys#copy-env-table et mff mf syms) mf) ) ) ) )

;;

(define (environment-ref env sym)
  (##sys#check-structure env 'environment 'environment-ref)
  (##sys#check-symbol sym 'environment-ref)
  (let* ([et (%environment-table env)]
         [val
           (if (%environment-table? et)
               ;then environment object
               (%environment-location-binding
                 (%environment-location/exist? et sym 'environment-ref))
               ;else interaction environment
               (%symbol-binding sym) )] )
    (if (unbound-value? val)
        (error/undefined-symbol 'environment-ref env sym)
        val ) ) )

;;

(define (environment-set! env sym val)
  (##sys#check-structure env 'environment 'environment-set!)
  (##sys#check-symbol sym 'environment-set!)
  (let ([et (%environment-table env)] )
    (if (%environment-table? et)
        ;then environment object
        (let ([eloc (%environment-location et sym (%environment-extensible? env))])
          (if eloc
              (%environment-location-bind! eloc val)
              (error/inextensible-environment 'environment-set! env)) )
        ;else interaction environment
        (%symbol-bind! sym val) ) ) )

;;

(define (environment-extend! env sym . v+m)
  (##sys#check-structure env 'environment 'environment-extend!)
  (##sys#check-symbol sym 'environment-extend!)
  (let ([et (%environment-table env)]
        [n (length v+m)] )
    (if (%environment-table? et)
        ;then environment object
        (let ([eloc (%environment-location et sym #t)])
          (when (> n 0) ;has value
            (%environment-location-bind! eloc (car v+m))
            (when (= n 2) ;has mutable flag
              (%environment-location-mutable-set! eloc (cadr v+m)) ) ) )
        ;else interaction environment
        (when (> n 0) ;has value
          (%symbol-bind! sym (car v+m)) ) ) ) )

;;

(define (environment-includes? env sym)
  (##sys#check-structure env 'environment 'environment-includes?)
  (##sys#check-symbol sym 'environment-includes?)
  (let ([et (%environment-table env)])
    (if (%environment-table? et)
        ;then environment object
        (->boolean (%environment-location et sym #f))
        ;else interaction environment
        (not (unbound-value? (%symbol-binding sym))) ) ) )

;;

(define (environment-set-mutable! env sym flag)
  (##sys#check-structure env 'environment 'environment-set-mutable!)
  (##sys#check-symbol sym 'environment-set-mutable!)
  (let ([et (%environment-table env)])
    ;Symbols always mutable in interaction environment
    (when (%environment-table? et)
      (%environment-location-mutable-set!
        (%environment-location/exist? et sym 'environment-set-mutable!)
        flag) ) ) )

;;

(define (environment-mutable? env sym)
  (##sys#check-structure env 'environment 'environment-mutable?)
  (let ([et (%environment-table env)])
    (or (not (%environment-table et)) ;Mutable interaction environment
        (%environment-location-mutable?
          (%environment-location/exist? et sym 'environment-mutable?)) ) ) )

;;

(define (environment-extendable? env)
  (##sys#check-structure env 'environment 'environment-extendable?)
  (%environment-extensible? env) )

;;

(define (environment-has-binding? env sym)
  (##sys#check-structure env 'environment 'environment-has-binding?)
  (##sys#check-symbol sym 'environment-has-binding?)
  (let ([et (%environment-table env)])
    (not
      (unbound-value?
        (if (%environment-table? et)
            ;then environment object
            (let ([eloc (%environment-location et sym #f)])
              (if eloc
                  (%environment-location-binding eloc)
                  UNBOUND-VALUE) )
            ;else interaction environment
            (%symbol-binding sym) ) ) ) ) )

;;

(define (environment-remove! env syms #!optional silent-flag)
  (##sys#check-structure env 'environment 'environment-remove!)
  (let ([et (%environment-table env)]
        [syms (cond
                [(symbol? syms) (list syms)]
                [(pair? syms)   syms]
                [else
                  (error/type/list 'environment-remove! syms)] ) ] )
    (if (%environment-table? et)
        ;then environment object
        (let ([len (%environment-table-size et)])
          (let loop0 ([syms syms])
            (cond
              [(null? syms)
                (void)]
              [(not (pair? syms))
                (##sys#not-a-proper-list-error syms)]
              [else
                (let* ([sym (car syms)]
                       [eloc (%environment-location et sym #f)] )
                  (let loop ([i 0])
                    (if (>= i len)
                        (if silent-flag
                            (loop0 (cdr syms))
                            (error/undefined-symbol 'environment-remove! env sym))
                        (let loop2 ([bckt (%environment-table-ref et i)] [prev #f])
                          (if (null? bckt)
                              (loop (+ i 1))
                              (let ([next (cdr bckt)])
                                (if (eq? (car bckt) eloc)
                                    (begin
                                      (if prev
                                        (set-cdr! prev next)
                                        (%environment-table-set! et i next) )
                                      (loop0 (cdr syms)) )
                                    (loop2 next bckt) ) ) ) ) ) ) ) ] ) ) )
        ;else interaction environment
        (error 'environment-remove!
          "cannot remove bindings from the interaction environment"
          env) ) ) )

;;

(define (environment-for-each env proc)
  (##sys#check-structure env 'environment 'environment-for-each)
  (let ([et (%environment-table env)])
    (if (%environment-table? et)
        ;then environment object
        (##sys#hash-table-for-each proc (%environment-table env))
        ;else interaction environment
        (##sys#walk-namespace (lambda (sym) (proc sym (%symbol-binding sym)))) ) ) )

;;

(define (environment-symbols env)
  (##sys#check-structure env 'environment 'environment-symbols)
  (##sys#environment-symbols env) )