source: project/release/3/misc-extn/trunk/misc-extn-symbol-support.scm @ 7388

Last change on this file since 7388 was 5437, checked in by Kon Lovett, 14 years ago

Release 3.0, where misc-extn.scm is rmvd & macros split into sep files.

File size: 1.8 KB
Line 
1;;;; misc-extn-symbol-support.scm
2;;;; Kon Lovett, Mar '05
3
4(eval-when (compile)
5  (declare
6    (fixnum)
7    (inline)
8    (no-procedure-checks)
9    (no-bound-checks)
10    (import
11      ##sys#interned-symbol?
12      ##sys#make-symbol
13      ##sys#symbol->qualified-string
14      ##sys#qualified-symbol-prefix
15      ##sys#intern-symbol)
16    (bound-to-procedure
17      ##sys#interned-symbol?
18      ##sys#make-symbol
19      ##sys#symbol->qualified-string
20      ##sys#qualified-symbol-prefix
21      ##sys#intern-symbol)
22    (export
23      interned-symbol?
24      symbol->qualified-string
25      make-qualified-uninterned-symbol
26      make-qualified-symbol
27      qualified-symbol?) ) )
28
29;;
30
31(define (check-symbol obj loc)
32  (unless (symbol? obj)
33    (error loc "invalid symbol" obj) ) )
34
35#;
36(define (check-symbol-or-string obj loc)
37  (unless (or (symbol? obj) (string? obj))
38    (error loc "invalid symbol or string" obj) ) )
39
40(define-constant NAMESPACE-MAX-ID-LEN 31)
41
42(define (make-qualified-string ns sym loc)
43  (check-symbol sym loc)
44  (let* ([ns (->string ns)]
45         [nsl (string-length ns)])
46    (if (<= 1 nsl NAMESPACE-MAX-ID-LEN)
47      (conc (integer->char nsl) ns sym)
48      (error loc "invalid namespace identifier length" ns) ) ) )
49
50;; Chicken namespace qualified symbol.
51
52(define (make-qualified-symbol ns sym)
53  (##sys#intern-symbol (make-qualified-string ns sym 'make-qualified-symbol)) )
54
55(define (make-qualified-uninterned-symbol ns sym)
56  (##sys#make-symbol (make-qualified-string ns sym 'make-qualified-symbol)) )
57
58(define (qualified-symbol? sym)
59  (check-symbol sym 'qualified-symbol?)
60  (not (not (##sys#qualified-symbol-prefix sym))) )
61
62(define (symbol->qualified-string sym)
63  (check-symbol sym 'symbol->qualified-string)
64  (##sys#symbol->qualified-string sym) )
65
66(define (interned-symbol? sym)
67  (check-symbol sym 'interned-symbol?)
68  (##sys#interned-symbol? sym) )
69 
Note: See TracBrowser for help on using the repository browser.