source: project/release/5/symbol-utils/trunk/symbol-name-utils.scm @ 37671

Last change on this file since 37671 was 37671, checked in by Kon Lovett, 3 months ago

keyword disjoint type so needs alias for earlier C5

File size: 3.1 KB
Line 
1;;;; symbol-name-utils.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3
4(module symbol-name-utils
5
6(;export
7  keyword->symbol
8  keyword->uninterned-symbol
9  symbol->keyword
10  symbol-printname-details
11  symbol-printname=? symbol-printname<?
12  symbol-printname-length
13  max-symbol-printname-length)
14
15(import scheme
16  (chicken base)
17  (chicken keyword)
18  (chicken fixnum)
19  (chicken type)
20  (only type-checks check-symbol check-list))
21
22;;
23
24(cond-expand
25  (chicken-5.0 (define-type keyword symbol))
26  (chicken-5.1)
27  (else))
28
29;;; Support
30
31;;
32
33(: exploded-qualified-symbol=? (string string string string --> boolean))
34;
35(define (exploded-qualified-symbol=? px sx py sy)
36  (and (string=? px py) (string=? sx sy)) )
37
38(: exploded-qualified-symbol<? (string string string string --> boolean))
39;
40(define (exploded-qualified-symbol<? px sx py sy)
41  (or
42    (and (string=? px py) (string<? sx sy))
43    (string<? px py)) )
44
45;;;
46
47;;
48
49(: keyword->symbol (keyword --> symbol))
50;
51(define (keyword->symbol kwd)
52  (string->symbol (keyword->string kwd)) )
53
54(: keyword->uninterned-symbol (keyword --> symbol))
55;
56(define (keyword->uninterned-symbol kwd)
57  (string->uninterned-symbol (keyword->string kwd)) )
58
59;;
60
61;symbol->string drops namespace qualification!
62;which means a keyword and a symbol of the same name have the same printname.
63
64(: symbol->keyword ((or keyword symbol) --> keyword))
65;
66(define (symbol->keyword sym)
67  (cond
68    ((keyword? sym) (the keyword sym))
69    (else           (string->keyword (symbol->string sym)) ) ) )
70
71;;
72
73(: *symbol-printname-details ((or keyword symbol) --> string string))
74;
75(define (*symbol-printname-details sym)
76  (cond
77    ((keyword? sym) (values (keyword->string sym) ":"))
78    (else           (values (symbol->string sym) ""))) )
79
80(: symbol-printname-details ((or keyword symbol) --> string string))
81;
82(define (symbol-printname-details sym)
83  (let-values (
84    ((s p) (*symbol-printname-details sym)))
85    ;do not expose the symbol's "raw" printname
86    (values (string-copy s) p) ) )
87
88;FIXME (forall (a ...) (a a --> boolean))
89
90(: symbol-printname=? ((or keyword symbol) (or keyword symbol) --> boolean))
91;
92(define (symbol-printname=? x y)
93  (let-values (
94    ((sx px) (*symbol-printname-details x))
95    ((sy py) (*symbol-printname-details y)) )
96    (exploded-qualified-symbol=? px sx py sy) ) )
97
98(: symbol-printname<? ((or keyword symbol) (or keyword symbol) --> boolean))
99;
100(define (symbol-printname<? x y)
101  (let-values (
102    ((sx px) (*symbol-printname-details x))
103    ((sy py) (*symbol-printname-details y)) )
104    (exploded-qualified-symbol<? px sx py sy) ) )
105
106;;
107
108(: symbol-printname-length ((or keyword symbol) --> fixnum))
109;
110(define (symbol-printname-length sym)
111  (cond
112    ((keyword? sym)
113      ;compensate for leading '###' when only a ':' is printed
114      (- (string-length (keyword->string sym)) 2) )
115    (else
116      (string-length (symbol->string sym)) ) ) )
117
118(: max-symbol-printname-length ((list-of symbol) --> fixnum))
119;
120(define (max-symbol-printname-length syms)
121  (if (null? (check-list 'max-symbol-printname-length syms))
122    '()
123    (apply max 0 (map symbol-printname-length syms)) ) )
124
125) ;module symbol-name-utils
Note: See TracBrowser for help on using the repository browser.