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

Last change on this file since 38624 was 38624, checked in by Kon Lovett, 5 months ago

better lolevel symenv access types, dedup macro syms (?)

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