(module environments

(make-environment
 environment-copy
 environment?
 interaction-environment?
 environment-empty?
 environment-extendable?
 environment-set-mutable!
 environment-mutable?
 environment-ref
 environment-set!
 environment-extend!
 environment-includes?
 environment-has-binding?
 environment-remove!
 environment-for-each
 environment-symbols
 environment)

(import chicken scheme)
(use data-structures srfi-1)

(define-record environment
  name
  (setter bindings)
  extendable?)

(define-syntax define*
  (syntax-rules ()
    ((_ name val)
     (begin
       (define-for-syntax name val)
       (define name val)))))

(define* *environment-name* "(anonymous)")

(define (unbind! binding)
  (unless (pair? (cdr binding))
    (##sys#setslot (cdr binding) 0 (##sys#slot '##sys#arbitrary-unbound-symbol 0))))

(define (environment-finalize! env)
  (for-each unbind! (environment-bindings env)))

;; make-environment          (make-environment [EXTENSIBLE?])
(set! make-environment
      (let ((make-env make-environment))
        (lambda (extendable? #!optional (name *environment-name*))
          (set-finalizer! (make-env name '() extendable?)
                          environment-finalize!))))

(define (module-environment? env)
  (symbol? (environment-name env)))

(set! environment-extendable?
      (let ((ext? environment-extendable?))
        (lambda (env)
          (and (not (module-environment? env))
               (ext? env)))))

;;   environment-extend!       (environment-extend! ENV SYMBOL [VALUE [MUTABLE?]])
;; TODO: respect `mutable?'
(define (environment-extend! env symbol
                             #!optional
                             (value (##sys#slot '##sys#arbitrary-unbound-symbol 0))
                             (mutable? #t))
  (let* ((alias (gensym symbol))
         (bindings (environment-bindings env))
         (old-alias (assq symbol bindings)))
    (when old-alias
      (unbind! old-alias))
    (##sys#setslot alias 0 value)
    (set! (environment-bindings env)
          (alist-update! symbol alias bindings))))

;;   environment-set!          (environment-set! ENV SYMBOL VALUE)
(define (environment-set! env symbol value)
  (if (not (environment-extendable? env))
      (error 'environment-extend! "environment is not extendable" env)
      (environment-extend! env symbol value)))

;;   environment-set-mutable!  (environment-set-mutable! ENV SYMBOL MUTABLE?)
(define (environment-set-mutable! env symbol mutable?)
  (error 'environment-set-mutable! "not implemented, yet"))

(define (binding->value binding)
  (##sys#slot (or (and (symbol? binding)
                       (get binding '##core#primitive))
                  binding) 0))

;; environment-copy          (environment-copy ENV [EXTENSIBLE? [SYMBOLS [MUTABLE?]]])
(define (environment-copy env #!optional extendable? symbols (mutable? extendable?))
  (let ((new (make-environment extendable?))
        (bindings (environment-bindings env)))
    (set! (environment-bindings new)
          (fold (lambda (binding bindings)
                  (if (pair? (cdr binding))
                      (cons binding bindings)
                      (let* ((sym (car binding))
                             (val (binding->value (cdr binding)))
                             (alias (gensym sym)))
                        (##sys#setslot alias 0 val)
                        (alist-cons sym alias bindings))))
                '()
                (if symbols
                    (map (lambda (sym)
                           (or (assq sym bindings)
                               (error 'environment-copy "symbol not bound in environment" sym)))
                         symbols)
                    bindings)))
    new))

;;   environment-empty?        (environment-empty? ENV) => boolean
(define (environment-empty? env)
  (null? (environment-bindings env)))

;;   environment-for-each      (environment-for-each ENV PROC)
(define (environment-for-each env proc)
  (for-each (lambda (binding)
              (proc (car binding) (##sys#slot (cdr binding) 0)))
            (environment-bindings env)))

;;   interaction-environment?  (interaction-environment? X) => boolean
(define (interaction-environment? env)
  (eq? (interaction-environment) env))

;;   environment-has-binding?  (environment-has-binding? ENV SYMBOL) => boolean
(define (environment-has-binding? env symbol)
  (any (lambda (binding)
         (eq? (car binding) symbol))
       (or (environment-bindings env) '()))) ; interaction-environment's bindings are #f

;;   environment-includes?     (environment-includes? ENV SYMBOL) => boolean
(define (environment-includes? env symbol)
  (or (interaction-environment? env)
      (environment-has-binding? env symbol)))

;;   environment-mutable?      (environment-mutable? ENV SYMBOL) => boolean
(define (environment-mutable? env symbol)
  (error 'environment-mutable? "not implemented, yet"))

;;   environment-ref           (environment-ref ENV SYMBOL) => *
(define (environment-ref env symbol)
  (let ((binding (alist-ref symbol (environment-bindings env))))
    (cond ((not binding)
           (error 'environment-ref "symbol is not bound in environment" symbol))
          ((pair? binding)
           (error 'environment-bindings "can't reference macro" symbol))
          (else (binding->value binding)))))

;;   environment-remove!       (environment-remove! ENV SYMBOLS [SILENT? [INEXTENSIBLE?]])
(define (environment-remove! env symbols #!optional silent? (inextensible? #t))
  (set! (environment-bindings env)
        (fold (lambda (sym bindings)
                (let ((binding (assq sym bindings)))
                  (unbind! binding)
                  (alist-delete! sym bindings)))
              (environment-bindings env)
              (if (pair? symbols)
                  symbols
                  (list symbols)))))

;;   environment-symbols       (environment-symbols ENV) => list
(define (environment-symbols env)
  (map car (environment-bindings env)))

(import-for-syntax srfi-1)

(define-syntax environment
  (ir-macro-transformer
   (lambda (x i c)
     (let ((exports (cadr x))
           (body (cddr x))
           (env  (gensym 'environment)))
       `(begin
          (module ,env ,exports . ,body)
          (let ((env (module-environment ',env)))
            (##sys#setslot env 1 ,*environment-name*)
            ;; don't clutter the module-table. is this a good idea?
            (set! ##sys#module-table (alist-delete! ',env ##sys#module-table))
            env))))))

)