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

Last change on this file since 38938 was 38938, checked in by Kon Lovett, 10 months ago

add -strict-types, type is interface

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