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

Last change on this file since 39779 was 39779, checked in by Kon Lovett, 6 months ago

fix test runner fail exit pass-thru, add test runner config

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  ;
22  search-interaction-environment-symbols
23  search-list-environment-symbols
24  ;
25  search-environments-symbols)
26
27(import scheme
28  (chicken base)
29  (chicken type)
30  (only (srfi 1) append!)
31  symbol-table-access)
32
33;;;
34
35;opaque
36(define-type macro-environment *)
37
38(: system-current-environment (-> list))
39(: system-macro-environment (-> list))
40(: macro-symbol-in-environment? (symbol macro-environment -> boolean))
41(: search-list-environment-symbols ((* -> boolean) (list-of (pair symbol *)) #!optional (pair -> *) --> list))
42(: search-interaction-environment-symbols ((* -> boolean) -> list))
43(: search-macro-environment-symbols ((* -> boolean) (list-of (pair symbol *)) --> list))
44(: search-system-environment-symbols ((* -> boolean) #!optional (or (list-of (pair symbol *)) boolean) -> list))
45(: search-environments-symbols ((* -> boolean) -> list))
46
47;;
48
49(define-inline (cons-if test? x xs) (if (test? x) (cons x xs) xs))
50
51;;
52
53(define system-current-environment ##sys#current-environment)
54(define system-macro-environment ##sys#macro-environment)
55
56(define macro-symbol-in-environment? ##sys#macro?)
57
58;;
59
60(define (search-list-environment-symbols test? env #!optional (itemref car))
61  (define (cons-if-symbol syms cell) (cons-if test? (itemref cell) syms))
62  (foldl cons-if-symbol '() env) )
63
64(define (search-interaction-environment-symbols test?)
65  (let loop ((cursor (cursor-first)) (syms '()))
66    (let ((sym (cursor-current cursor)))
67      (if (not sym)
68        syms
69        (loop (cursor-next cursor) (cons-if test? sym syms)) ) ) ) )
70
71;;
72
73(define (search-macro-environment-symbols test? env)
74  (search-list-environment-symbols test? env) )
75
76(define (search-system-environment-symbols test? #!optional env)
77  (if (list? env)
78    (search-list-environment-symbols test? env)
79    (search-interaction-environment-symbols test?) ) )
80
81;;
82
83(define (search-environments-symbols test?)
84  (append!
85    (search-system-environment-symbols test? (system-current-environment))
86    (search-system-environment-symbols test? (system-macro-environment))
87    (search-system-environment-symbols test?)) )
88
89) ;module symbol-environment-access
Note: See TracBrowser for help on using the repository browser.