Changeset 35740 in project


Ignore:
Timestamp:
07/05/18 02:14:37 (5 months ago)
Author:
kon
Message:

"atomize" module into 4 + existing-exports

Location:
release/4/symbol-utils/trunk
Files:
4 added
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/symbol-utils/trunk/symbol-utils.meta

    r35124 r35740  
    1111        (check-errors "1.9.0"))
    1212 (test-depends test)
    13  (files "symbol-utils.setup" "symbol-utils.meta" "symbol-utils.scm" "tests/run.scm" "tests/symbol-utils-test.scm") )
     13 (files
     14  "symbol-utils.meta" "symbol-utils.setup"
     15  "symbol-utils.scm"
     16  "symbol-name-utils.scm" "symbol-value-utils.scm" "symbol-qualified-utils.scm" "symbol-lolevel-utils.scm"
     17  "tests/run.scm" "tests/symbol-utils-test.scm") )
  • release/4/symbol-utils/trunk/symbol-utils.scm

    r35245 r35740  
    11;;;; symbol-utils.scm
     2;;;; Kon Lovett, Jul '18
     3;;;; Kon Lovett, Aug '17
    24;;;; Kon Lovett, Aug '10
    3 ;;;; Kon Lovett, Aug '17
    45
    5 (module symbol-utils
    6 
    7 (;export
    8   unbound-value unbound-value? unbound?
    9   symbol-value
    10   unspecified-value unspecified-value? unspecified?
    11   symbol->keyword
    12   symbol-printname-details
    13   symbol-printname=? symbol-printname<?
    14   symbol-printname-length
    15   max-symbol-printname-length
    16   interned-symbol?
    17   symbol->qualified-string
    18   make-qualified-uninterned-symbol
    19   make-qualified-symbol
    20   qualified-symbol? )
     6(module symbol-utils ()
    217
    228(import scheme chicken)
    239(use
    24   (only data-structures
    25     ->string)
    26   (only type-checks
    27     check-symbol check-list) )
     10  symbol-name-utils symbol-value-utils symbol-qualified-utils symbol-lolevel-utils)
    2811
    29 (declare
    30   (always-bound
    31     ##sys#arbitrary-unbound-symbol)
    32   (bound-to-procedure
    33     ##sys#symbol->string
    34     ##sys#interned-symbol?
    35     ##sys#make-symbol
    36     ##sys#symbol->qualified-string
    37     ##sys#qualified-symbol-prefix
    38     ##sys#intern-symbol ) )
    39 
    40 ;;;
    41 
    42 (define (->boolean obj)
    43   (and
    44     obj
    45     #t ) )
    46 
    47 ;;; Special Values
    48 
    49 ;; Unbound
    50 
    51 (define-syntax unbound-value
    52         (syntax-rules ()
    53                 ((_)
    54                         (##sys#slot '##sys#arbitrary-unbound-symbol 0) ) ) )
    55 
    56 (define-syntax unbound-value?
    57         (syntax-rules ()
    58                 ((_ ?val)
    59                         (eq? (unbound-value) ?val) ) ) )
    60 
    61 (define-syntax unbound?
    62         (syntax-rules ()
    63                 ((_ ?sym)
    64                         (unbound-value? (##sys#slot ?sym 0)) ) ) )
    65 
    66 (define-syntax symbol-value
    67         (syntax-rules ()
    68     ;
    69     ((_ ?sym ?def)
    70       (let ((val (##sys#slot ?sym 0)))
    71         (if (unbound-value? val) ?def val) ) )
    72     ;
    73     ((_ ?sym)
    74       (symbol-value ?sym #f) ) ) )
    75 
    76 ;; Undefined
    77 
    78 (define unspecified-value void)
    79 
    80 (define-syntax unspecified-value?
    81         (syntax-rules ()
    82                 ((_ ?val)
    83                         (eq? (unspecified-value) ?val) ) ) )
    84 
    85 (define-syntax unspecified?
    86         (syntax-rules ()
    87                 ((_ ?obj)
    88                         (unspecified-value? ?obj) ) ) )
    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 (: symbol->keyword (symbol --> symbol))
    96 ;
    97 (define (symbol->keyword sym)
    98   (if (keyword? sym)
    99     sym
    100     (string->keyword (symbol->string (check-symbol 'symbol->keyword sym))) ) )
    101 
    102 ;;
    103 
    104 (: *symbol-printname-details (symbol --> string string))
    105 ;
    106 (define (*symbol-printname-details sym)
    107   (let ((p (##sys#qualified-symbol-prefix sym)) )
    108     (values
    109       (##sys#symbol->string sym)
    110       (cond
    111         ((not p)                      "" )
    112         ((eq? #\x0 (string-ref p 0))  ":")
    113         (else                         (substring p 1) ) ) ) ) )
    114 
    115 (: symbol-printname-details (symbol --> string string))
    116 ;
    117 (define (symbol-printname-details sym)
    118   (let-values (
    119     ((s p) (*symbol-printname-details (check-symbol 'symbol-printname-details sym))))
    120     ;do not expose the symbol's "raw" printname
    121     (values (string-copy s) p) ) )
    122 
    123 ;;
    124 
    125 (: qualified=? (string string string string --> boolean))
    126 ;
    127 (define (qualified=? px sx py sy)
    128   (and (string=? px py) (string=? sx sy)) )
    129 
    130 (: qualified<? (string string string string --> boolean))
    131 ;
    132 (define (qualified<? px sx py sy)
    133   (or
    134     (and (string=? px py) (string<? sx sy))
    135     (string<? px py)) )
    136 
    137 (: symbol-printname=? (symbol symbol --> boolean))
    138 ;
    139 (define (symbol-printname=? x y)
    140   (let-values (
    141     ((sx px) (*symbol-printname-details (check-symbol 'symbol-printname=? x)))
    142     ((sy py) (*symbol-printname-details (check-symbol 'symbol-printname=? y))) )
    143     (qualified=? px sx py sy) ) )
    144 
    145 (: symbol-printname<? (symbol symbol --> boolean))
    146 ;
    147 (define (symbol-printname<? x y)
    148   (let-values (
    149     ((sx px) (*symbol-printname-details (check-symbol 'symbol-printname<? x)))
    150     ((sy py) (*symbol-printname-details (check-symbol 'symbol-printname<? y))) )
    151     (qualified<? px sx py sy) ) )
    152 
    153 ;;
    154 
    155 #; ;Easier to read but more overhead
    156 (define (symbol-printname-length sym)
    157   (cond
    158     ((keyword? sym)
    159       (+ 1 (string-length (##sys#symbol->string sym))) )
    160     ((##sys#qualified-symbol? sym)
    161       (string-length (##sys#symbol->qualified-string sym)) )
    162     (else
    163       (string-length (##sys#symbol->string sym)) ) ) )
    164 
    165 (: symbol-printname-length (symbol --> fixnum))
    166 ;
    167 (define (symbol-printname-length sym)
    168   (let (
    169     (len
    170       (string-length
    171         (##sys#symbol->qualified-string
    172           (check-symbol 'symbol-printname-length sym)))) )
    173     (if (keyword? sym)
    174       (fx- len 2) ;compensate for leading '###' when only a ':' is printed
    175       len ) ) )
    176 
    177 (: max-symbol-printname-length ((list-of symbol) --> fixnum))
    178 ;
    179 (define (max-symbol-printname-length syms)
    180   (if (null? (check-list 'max-symbol-printname-length syms))
    181     '()
    182     (apply max (map symbol-printname-length syms)) ) )
    183 
    184 ;;
    185 
    186 (define-constant NAMESPACE-MAX-ID-LEN 31)
    187 
    188 (define (valid-prefix-length? len)
    189   (and (fx<= 1 len) (fx<= len NAMESPACE-MAX-ID-LEN)) )
    190 
    191 (define (%fixnum->char n)
    192   (##core#inline "C_make_character" (##core#inline "C_unfix" n)) )
    193 
    194 ;Note keywords are in the null namespace!
    195 
    196 (: make-qualified-string (symbol * * --> string))
    197 ;
    198 (define (make-qualified-string loc prefix name)
    199   (let* (
    200     (name       (->string name))
    201     (prefix     (->string prefix))
    202     (prefix-len (##sys#size prefix)) )
    203     (unless (valid-prefix-length? prefix-len)
    204       (error loc "invalid namespace identifier length" prefix) )
    205     (let (
    206       (length-prefix (##sys#make-string 1 (%fixnum->char prefix-len))) )
    207       (##sys#fragments->string
    208         (fx+ 1 (fx+ prefix-len (##sys#size name)))
    209         `(,length-prefix ,prefix ,name)) ) ) )
    210 
    211 ;; Chicken namespace qualified symbol.
    212 
    213 (: make-qualified-symbol (* * --> symbol))
    214 ;
    215 (define (make-qualified-symbol prefix name)
    216   (##sys#intern-symbol
    217     (make-qualified-string 'make-qualified-symbol prefix name)) )
    218 
    219 (: make-qualified-uninterned-symbol (* * --> symbol))
    220 ;
    221 (define (make-qualified-uninterned-symbol prefix name)
    222   (##sys#make-symbol
    223     (make-qualified-string 'make-qualified-symbol prefix name)) )
    224 
    225 (: qualified-symbol? (* -> boolean : symbol))
    226 ;
    227 (define (qualified-symbol? sym)
    228   (and
    229     (symbol? sym)
    230     (->boolean (##sys#qualified-symbol-prefix sym))) )
    231 
    232 (: symbol->qualified-string (symbol --> string))
    233 ;
    234 (define (symbol->qualified-string sym)
    235   (##sys#symbol->qualified-string (check-symbol 'symbol->qualified-string sym)) )
    236 
    237 (: interned-symbol? (symbol --> boolean))
    238 ;
    239 (define (interned-symbol? sym)
    240   (##sys#interned-symbol? (check-symbol 'interned-symbol? sym)) )
     12(reexport
     13  symbol-name-utils symbol-value-utils symbol-qualified-utils symbol-lolevel-utils)
    24114
    24215) ;module symbol-utils
  • release/4/symbol-utils/trunk/symbol-utils.setup

    r34415 r35740  
    55(verify-extension-name "symbol-utils")
    66
    7 (setup-shared-extension-module 'symbol-utils (extension-version "1.0.3")
     7(setup-shared-extension-module 'symbol-lolevel-utils (extension-version "1.1.0")
    88  #:inline? #t
    99  #:types? #t
    10   #:compile-options '(
    11     -scrutinize
    12     -fixnum-arithmetic
    13     -O3 -d1
    14     -no-procedure-checks))
     10  #:compile-options '(-scrutinize -O3 -d1 -no-procedure-checks))
     11
     12(setup-shared-extension-module 'symbol-value-utils (extension-version "1.1.0")
     13  #:inline? #t
     14  #:types? #t
     15  #:compile-options '(-scrutinize -O3 -d1 -no-procedure-checks))
     16
     17(setup-shared-extension-module 'symbol-qualified-utils (extension-version "1.1.0")
     18  #:inline? #t
     19  #:types? #t
     20  #:compile-options '(-scrutinize -O3 -d1 -no-procedure-checks))
     21
     22(setup-shared-extension-module 'symbol-name-utils (extension-version "1.1.0")
     23  #:inline? #t
     24  #:types? #t
     25  #:compile-options '(-scrutinize -O3 -d1 -no-procedure-checks))
     26
     27(setup-shared-extension-module 'symbol-utils (extension-version "1.1.0")
     28  #:inline? #t
     29  #:types? #t
     30  #:compile-options '(-scrutinize -O3 -d1 -no-procedure-checks))
Note: See TracChangeset for help on using the changeset viewer.