;;;; symbol-environment-access.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18

(declare
  (bound-to-procedure
    ##sys#macro-environment
    ##sys#current-environment
    ##sys#macro?))

(module symbol-environment-access

(;export
  ;
  system-current-environment
  system-macro-environment
  ;
  macro-symbol-in-environment?
  ;
  search-macro-environment-symbols
  search-system-environment-symbols
  ;
  search-interaction-environment-symbols
  search-list-environment-symbols)

(import scheme
  (chicken base)
  (chicken type)
  symbol-table-access)

;;;

;opaque
(define-type macro-environment *)

;;

(define-inline (cons-if test? x xs) (if (test? x) (cons x xs) xs))

;;;

;;

(define system-current-environment ##sys#current-environment)

(define system-macro-environment ##sys#macro-environment)

;;

(: macro-symbol-in-environment? ((or boolean symbol) (or boolean macro-environment) -> boolean))
;
(define (macro-symbol-in-environment? sym macenv)
  (and sym macenv (##sys#macro? sym macenv)) )

;;

(: search-list-environment-symbols (list procedure --> list))
;
(define (search-list-environment-symbols env test?)
  (foldl (lambda (syms cell) (cons-if test? (car cell) syms)) '() env) )

(: search-interaction-environment-symbols (* procedure --> list))
;
(define (search-interaction-environment-symbols env test?)
  (let loop ((cursor (cursor-first)) (syms '()))
    (let ((sym (cursor-current cursor)))
      (if (not sym)
        syms
        (loop (cursor-next cursor) (cons-if test? sym syms)) ) ) ) )

;;

(: search-macro-environment-symbols (list procedure --> list))
;
(define (search-macro-environment-symbols env test?)
  (search-list-environment-symbols env test?) )

(: search-system-environment-symbols (list procedure --> list))
;
(define (search-system-environment-symbols env test?)
  (if env
    (search-list-environment-symbols env test?)
    (search-interaction-environment-symbols env test?) ) )

) ;module symbol-environment-access