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

Last change on this file since 37126 was 37126, checked in by Kon Lovett, 7 months ago

comment, add parameter, dep global, better internal check, fix doc

File size: 1.8 KB
Line 
1;;;; symbol-access.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3
4(declare
5  (bound-to-procedure
6    ##sys#symbol-has-toplevel-binding?))
7
8(module symbol-access
9
10(;export
11  ;
12  *toplevel-module-symbol*
13  toplevel-module-symbol
14  ;
15  global-symbol-bound?
16  global-symbol-ref
17  ;
18  internal-module-name?
19  ;
20  split-prefixed-symbol)
21
22(import scheme
23  (chicken base)
24  (chicken fixnum)
25  (chicken type)
26  (only (srfi 13) string-skip string-drop string-take string-index))
27
28;;;
29
30;;
31
32(define (internal-marker-prefix-length str)
33  (cond
34    ((string-skip str #\#) => identity)
35    (else                             0)) )
36
37(define (global-symbol-name-offset str)
38  (string-index str #\# (internal-marker-prefix-length str)) )
39
40;;;
41
42;; Toplevel Symbols
43
44(define-constant TOPLEVEL-MODULE-SYMBOL '||)
45
46(: *toplevel-module-symbol* (deprecated toplevel-module-symbol))
47(define *toplevel-module-symbol* TOPLEVEL-MODULE-SYMBOL)
48
49(define toplevel-module-symbol (make-parameter TOPLEVEL-MODULE-SYMBOL (lambda (x)
50  (or
51    (and (symbol? x) x)
52    (toplevel-module-symbol)))))
53
54(define *toplevel-module-string* (symbol->string (toplevel-module-symbol)))
55
56;; Raw Access Renames
57
58(define (global-symbol-bound? sym) (##sys#symbol-has-toplevel-binding? sym))
59
60(define (global-symbol-ref sym) (##sys#slot sym 0))
61
62;;
63
64(: internal-module-name? (string --> boolean))
65;
66(define (internal-module-name? str)
67  (not (zero? (internal-marker-prefix-length str))) )
68
69(: split-prefixed-symbol (symbol --> string string))
70;=> module-name identifier-name
71;
72(define (split-prefixed-symbol sym)
73  (let* (
74    ;symbol name (keyword w/o print-mark)
75    (str (symbol->string sym))
76    ;module break char index
77    (idx (global-symbol-name-offset str)) )
78    ;module?
79    (if idx
80      (values (string-take str idx) (string-drop str (fx+ 1 idx)))
81      (values *toplevel-module-string* str) ) ) )
82
83) ;module symbol-access
Note: See TracBrowser for help on using the repository browser.