source: project/release/5/apropos/trunk/symbol-environment-access.scm @ 40266

Last change on this file since 40266 was 40266, checked in by Kon Lovett, 2 months ago

updated test runner, comments, reflow

File size: 2.5 KB
Line 
1;;;; symbol-environment-access.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3
4(declare
5  (bound-to-procedure
6    ##sys#macro-environment
7    ##sys#current-environment
8    ##sys#macro?))
9
10(module symbol-environment-access
11
12(;export
13  ;
14  system-current-environment
15  system-macro-environment
16  ;
17  macro-symbol-in-environment?
18  ;
19  search-macro-environment-symbols
20  search-system-environment-symbols
21  search-environments-symbols
22  ;
23  search-interaction-environment-symbols
24  search-list-environment-symbols)
25
26(import scheme
27  (chicken base)
28  (chicken type)
29  (only (srfi 1) append!)
30  symbol-table-access)
31
32;;;
33
34;opaque
35(define-type macro-environment list)
36
37(: system-current-environment (-> list))
38(: system-macro-environment (-> list))
39(: macro-symbol-in-environment? (symbol macro-environment -> boolean))
40(: search-list-environment-symbols ((* -> boolean) (list-of (pair symbol *)) #!optional (pair -> *) --> list))
41(: search-interaction-environment-symbols ((* -> boolean) -> list))
42(: search-macro-environment-symbols ((* -> boolean) (list-of (pair symbol *)) --> list))
43(: search-system-environment-symbols ((* -> boolean) #!optional (or (list-of (pair symbol *)) boolean) -> list))
44(: search-environments-symbols ((* -> boolean) -> list))
45
46;;
47
48(define-inline (cons-if test? x xs) (if (test? x) (cons x xs) xs))
49
50;;
51
52(define system-current-environment ##sys#current-environment)
53(define system-macro-environment ##sys#macro-environment)
54
55(define macro-symbol-in-environment? ##sys#macro?)
56
57;;
58
59(define (search-list-environment-symbols test? env #!optional (elmref car))
60  (define (cons-if-symbol syms cell) (cons-if test? (elmref cell) syms))
61  (foldl cons-if-symbol '() env) )
62
63(define (search-interaction-environment-symbols test?)
64  (let loop ((cursor (cursor-first)) (syms '()))
65    (let ((sym (cursor-current cursor)))
66      (if (not sym)
67        syms
68        (loop (cursor-next cursor) (cons-if test? sym syms)) ) ) ) )
69
70;;
71
72(define (search-macro-environment-symbols test? env)
73  (search-list-environment-symbols test? env) )
74
75(define (search-system-environment-symbols test? #!optional env)
76  (if (list? env)
77    (search-list-environment-symbols test? env)
78    (search-interaction-environment-symbols test?) ) )
79
80;;
81
82;UNUSED
83(define (search-environments-symbols test?)
84  (append!
85    (search-macro-environment-symbols test? (system-macro-environment))
86    (search-system-environment-symbols test? (system-current-environment))
87    (search-system-environment-symbols test?)) )
88
89) ;module symbol-environment-access
Note: See TracBrowser for help on using the repository browser.