101 lines
2.8 KiB
Scheme
101 lines
2.8 KiB
Scheme
|
;;;; symbol-environment-access.scm -*- Scheme -*-
|
||
|
|
;;;; Kon Lovett, Jul '18
|
||
|
|
|
||
|
|
(declare
|
||
|
|
(bound-to-procedure
|
||
|
|
##sys#macro-environment
|
||
|
|
##sys#current-environment
|
||
|
|
##sys#macro?))
|
||
|
|
|
||
|
|
#|
|
||
|
|
##sys namespace
|
||
|
|
|
||
|
|
;alist
|
||
|
|
module-table (list-of (pair module-identifier module))
|
||
|
|
module-name (module --> symbol)
|
||
|
|
|
||
|
|
(for-each (lambda (e) (assert (eq? (car e) (##sys#module-name (cdr e)))))
|
||
|
|
##sys#module-table)
|
||
|
|
|
||
|
|
module-alias-environment ???
|
||
|
|
module-exports ???
|
||
|
|
|#
|
||
|
|
|
||
|
|
(include-relative "symbol-table-access")
|
||
|
|
|
||
|
|
(module symbol-environment-access
|
||
|
|
|
||
|
|
(;export
|
||
|
|
;
|
||
|
|
system-current-environment
|
||
|
|
system-macro-environment
|
||
|
|
;
|
||
|
|
macro-symbol-in-environment?
|
||
|
|
;
|
||
|
|
search-macro-environment-symbols
|
||
|
|
search-system-environment-symbols
|
||
|
|
#; ;UNUSED
|
||
|
|
search-environments-symbols
|
||
|
|
;
|
||
|
|
search-interaction-environment-symbols
|
||
|
|
search-list-environment-symbols)
|
||
|
|
|
||
|
|
(import scheme)
|
||
|
|
(import (chicken base))
|
||
|
|
(import (chicken type))
|
||
|
|
#; ;UNUSED
|
||
|
|
(import (only (srfi 1) append!))
|
||
|
|
(import (prefix symbol-table-access symbol-table-))
|
||
|
|
|
||
|
|
;opaque
|
||
|
|
(define-type macro-environment list)
|
||
|
|
|
||
|
|
(: system-current-environment (-> list))
|
||
|
|
(: system-macro-environment (-> list))
|
||
|
|
(: macro-symbol-in-environment? (symbol macro-environment -> boolean))
|
||
|
|
(: search-list-environment-symbols ((* -> boolean) (list-of (pair symbol *)) #!optional (pair -> *) --> list))
|
||
|
|
(: search-interaction-environment-symbols ((* -> boolean) -> list))
|
||
|
|
(: search-macro-environment-symbols ((* -> boolean) (list-of (pair symbol *)) --> list))
|
||
|
|
(: search-system-environment-symbols ((* -> boolean) #!optional (or (list-of (pair symbol *)) boolean) -> list))
|
||
|
|
(: search-environments-symbols ((* -> boolean) -> list))
|
||
|
|
|
||
|
|
;;
|
||
|
|
|
||
|
|
(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)
|
||
|
|
|
||
|
|
(define macro-symbol-in-environment? ##sys#macro?)
|
||
|
|
|
||
|
|
;;
|
||
|
|
|
||
|
|
(define (search-list-environment-symbols test? env #!optional (elmref car))
|
||
|
|
(define (cons-if-symbol syms cell) (cons-if test? (elmref cell) syms))
|
||
|
|
(foldl cons-if-symbol '() env) )
|
||
|
|
|
||
|
|
(define (search-interaction-environment-symbols test?)
|
||
|
|
(symbol-table-cursor-foldl (lambda (syms sym) (cons-if test? sym syms)) '()) )
|
||
|
|
|
||
|
|
;;
|
||
|
|
|
||
|
|
(define (search-macro-environment-symbols test? env)
|
||
|
|
(search-list-environment-symbols test? env) )
|
||
|
|
|
||
|
|
(define (search-system-environment-symbols test? #!optional env)
|
||
|
|
(if (list? env)
|
||
|
|
(search-list-environment-symbols test? env)
|
||
|
|
(search-interaction-environment-symbols test?) ) )
|
||
|
|
|
||
|
|
;;
|
||
|
|
|
||
|
|
#; ;UNUSED
|
||
|
|
(define (search-environments-symbols test?)
|
||
|
|
(append! (search-macro-environment-symbols test? (system-macro-environment))
|
||
|
|
(search-system-environment-symbols test? (system-current-environment))
|
||
|
|
(search-system-environment-symbols test?)) )
|
||
|
|
|
||
|
|
) ;module symbol-environment-access
|