Changeset 35124 in project


Ignore:
Timestamp:
02/16/18 19:48:09 (7 months ago)
Author:
kon
Message:

re-flow , enforce Postel's law , remove unused

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

Legend:

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

    r27660 r35124  
    1111        (check-errors "1.9.0"))
    1212 (test-depends test)
    13  (files "symbol-utils.setup" "symbol-utils.meta" "symbol-utils.scm" "symbol-utils.release-info" "tests/run.scm") )
     13 (files "symbol-utils.setup" "symbol-utils.meta" "symbol-utils.scm" "tests/run.scm" "tests/symbol-utils-test.scm") )
  • release/4/symbol-utils/trunk/symbol-utils.scm

    r34415 r35124  
    2020  qualified-symbol? )
    2121
    22 (import
    23   scheme
    24   chicken
     22(import scheme chicken)
     23(use
    2524  (only data-structures
    2625    ->string conc)
     
    2827    define-check+error-type
    2928    check-symbol) )
    30 (require-library
    31   data-structures
    32   type-checks)
    3329
    3430(declare
     
    4339    ##sys#intern-symbol ) )
    4440
     41;;;
     42
     43(define (->boolean obj)
     44  (and
     45    obj
     46    #t ) )
     47
    4548;;; Special Values
    4649
     
    108111
    109112(define (symbol-printname-details sym)
    110   (let-values (((s p) (*symbol-printname-details sym)))
     113  (let-values (
     114    ((s p) (*symbol-printname-details sym)))
    111115    ;do not expose the symbol's "raw" printname
    112116    (values (string-copy s) p) ) )
     
    114118;;
    115119
     120(define (qualified=? px sx py sy)
     121  (and (string=? px py) (string=? sx sy)) )
     122
     123(define (qualified<? px sx py sy)
     124  (or
     125    (and (string=? px py) (string<? sx sy))
     126    (string<? px py)) )
     127
    116128(define (symbol-printname=? x y)
    117   ;
    118   (define (qualified=? px sx py sy)
    119     (and (string=? px py) (string=? sx sy)) )
    120   ;
    121   (let-values (((sx px) (*symbol-printname-details x))
    122                ((sy py) (*symbol-printname-details y)) )
     129  (let-values (
     130    ((sx px) (*symbol-printname-details x))
     131    ((sy py) (*symbol-printname-details y)) )
    123132    (qualified=? px sx py sy) ) )
    124133
    125134(define (symbol-printname<? x y)
    126   ;
    127   (define (qualified<? px sx py sy)
    128     (or (and (string=? px py) (string<? sx sy))
    129         (string<? px py)) )
    130   ;
    131   (let-values (((sx px) (*symbol-printname-details x))
    132                ((sy py) (*symbol-printname-details y)) )
     135  (let-values (
     136    ((sx px) (*symbol-printname-details x))
     137    ((sy py) (*symbol-printname-details y)) )
    133138    (qualified<? px sx py sy) ) )
    134139
     
    146151
    147152(define (symbol-printname-length sym)
    148   (let ((len (string-length (##sys#symbol->qualified-string sym))))
     153  (let (
     154    (len (string-length (##sys#symbol->qualified-string sym))) )
    149155    (if (keyword? sym)
    150       (- len 2) ;compensate for leading '###' when only a ':' is printed
     156      (fx- len 2) ;compensate for leading '###' when only a ':' is printed
    151157      len ) ) )
    152158
     
    160166(define-constant NAMESPACE-MAX-ID-LEN 31)
    161167
     168(define (valid-prefix-length? len)
     169  (and (fx<= 1 len) (fx<= len NAMESPACE-MAX-ID-LEN)) )
     170
    162171(define (%fixnum->char n)
    163172  (##core#inline "C_make_character" (##core#inline "C_unfix" n)) )
     
    165174;Note keywords are in the null namespace!
    166175
    167 (define (symbol-or-string? obj)
    168   (or (symbol? obj) (string? obj)) )
    169 
    170 (define-check+error-type symbol-or-string)
    171 
    172 #; ;UNUSED
    173 (define (make-qualified-string prefix name)
    174   (let ((str (->string name)))
    175     (let* ((prefix (->string prefix))
    176            (prefix-len (##sys#size prefix)) )
    177       (if (<= 1 prefix-len NAMESPACE-MAX-ID-LEN)
    178         (##sys#fragments->string
    179           (+ 1 prefix-len (##sys#size str))
    180           `(,(##sys#make-string 1 (%fixnum->char prefix-len))
    181             ,prefix
    182             ,str))
    183         (error loc "invalid namespace identifier length" prefix) ) ) ) )
    184 
    185176(define (make-qualified-string loc prefix name)
    186   ;symbol or string
    187   (check-symbol-or-string loc prefix "qualifier")   ;namespace
    188   (check-symbol-or-string loc name "qualified")  ;basename
    189   (let ((str (if (symbol? name) (##sys#symbol->string name) name)))
    190     (let* ((prefix (if (symbol? prefix) (##sys#symbol->string prefix) prefix))
    191            (prefix-len (##sys#size prefix)))
    192       (if (<= 1 prefix-len NAMESPACE-MAX-ID-LEN)
    193         (##sys#fragments->string
    194           (+ 1 prefix-len (##sys#size str))
    195           `(,(##sys#make-string 1 (%fixnum->char prefix-len))
    196             ,prefix
    197             ,str))
    198         (error loc "invalid namespace identifier length" prefix) ) ) ) )
     177  (let* (
     178    (name       (->string name))
     179    (prefix     (->string prefix))
     180    (prefix-len (##sys#size prefix)) )
     181    (unless (valid-prefix-length? prefix-len)
     182      (error loc "invalid namespace identifier length" prefix) )
     183    (let (
     184      (length-prefix (##sys#make-string 1 (%fixnum->char prefix-len))) )
     185      (##sys#fragments->string
     186        (fx+ 1 (fx+ prefix-len (##sys#size name)))
     187        `(,length-prefix ,prefix ,name)) ) ) )
    199188
    200189;; Chicken namespace qualified symbol.
     
    209198
    210199(define (qualified-symbol? sym)
    211   (and
    212     (##sys#qualified-symbol-prefix (check-symbol 'qualified-symbol? sym))
    213     #t ) )
     200  (->boolean
     201    (##sys#qualified-symbol-prefix (check-symbol 'qualified-symbol? sym))) )
    214202
    215203(define (symbol->qualified-string sym)
  • release/4/symbol-utils/trunk/tests/run.scm

    r34415 r35124  
    1 ;;;;
    21
    3 (use test)
     2(define EGG-NAME "symbol-utils")
    43
    5 (use symbol-utils)
     4;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    65
    7 (test #:foo (symbol->keyword 'foo))
     6(use files)
    87
    9 (test-assert (unbound-value? (unbound-value)))
     8;no -disable-interrupts
     9(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
    1010
    11 (test-assert (symbol-value symbol->keyword #f))
     11(define *args* (argv))
    1212
    13 (test-assert (unspecified? (unspecified-value)))
     13(define (test-name #!optional (eggnam EGG-NAME))
     14  (string-append eggnam "-test") )
    1415
    15 (test-assert (symbol-printname=? 'foo 'foo))
    16 (test-assert (not (symbol-printname=? 'foo 'bar)))
    17 (test-assert (symbol-printname=? '##sys#list->string '##sys#list->string))
    18 (test-assert (not (symbol-printname=? '##sys#list->string 'list->string)))
     16(define (egg-name #!optional (def EGG-NAME))
     17  (cond
     18    ((<= 4 (length *args*))
     19      (cadddr *args*) )
     20    (def
     21      def )
     22    (else
     23      (error 'test "cannot determine egg-name") ) ) )
    1924
    20 (test-assert (not (symbol-printname<? 'foo 'foo)))
    21 (test-assert (symbol-printname<? 'bar 'foo))
    22 (test-assert (not (symbol-printname<? '##sys#list->string '##sys#list->string)))
    23 (test-assert (symbol-printname<? 'list->string '##sys#list->string))
     25;;;
    2426
    25 (test 3 (symbol-printname-length 'foo))
     27(set! EGG-NAME (egg-name))
    2628
    27 (test 3 (max-symbol-printname-length '(a abc ab)))
     29(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
     30  (let ((tstnam (test-name eggnam)))
     31    (print "*** csi ***")
     32    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
     33    (newline)
     34    (print "*** csc (" cscopts ") ***")
     35    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
     36    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
    2837
    29 (test '##foo#bar (make-qualified-symbol "foo" 'bar))
     38(define (run-tests eggnams #!optional (cscopts *csc-options*))
     39  (for-each (cut run-test <> cscopts) eggnams) )
    3040
    31 (test-assert (qualified-symbol? '##sys#list->string))
    32 (test-assert (not (qualified-symbol? 'sym)))
     41;;;
    3342
    34 (test "##sys#list->string" (symbol->qualified-string '##sys#list->string))
    35 (test "list->string" (symbol->qualified-string 'list->string))
    36 
    37 (test-assert (interned-symbol? 'foo))
    38 (test-assert (not (interned-symbol? (gensym))))
    39 
    40 (test-assert (not (interned-symbol? (make-qualified-uninterned-symbol "bar" 'foo))))
    41 
    42 (test-exit)
     43(run-test)
Note: See TracChangeset for help on using the changeset viewer.