Changeset 34123 in project


Ignore:
Timestamp:
05/30/17 05:45:24 (3 months ago)
Author:
kon
Message:

re-flow, rum lookup-table, fix hex ret

Location:
release/4/string-utils
Files:
14 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/string-utils/tags/1.2.5/memoized-string.scm

    r19894 r34123  
    44(module memoized-string
    55
    6   (;export
    7     make-string*)
     6(;export
     7  make-string* *make-string*)
    88
    9   (import
    10     scheme
    11     chicken
    12     (only lookup-table
    13       make-dict dict-ref dict-set! dict-update-dict!)
    14     (only miscmacros
    15       if*)
    16     (only unicode-utils
    17       ascii-codepoint? unicode-make-string)
    18     (only type-checks
    19       check-natural-fixnum check-char))
     9(import scheme chicken)
    2010
    21   (require-library
    22     miscmacros lookup-table type-checks
    23     unicode-utils)
    24 
    25   (declare
    26     (bound-to-procedure
    27       ##sys#make-string))
     11(import
     12  (only srfi-69
     13    make-hash-table hash-table-ref/default hash-table-set!)
     14  (only unicode-utils
     15    ascii-codepoint? unicode-make-string)
     16  (only type-checks
     17    check-natural-fixnum check-char))
     18(require-library
     19  srfi-69
     20  unicode-utils
     21  type-checks)
    2822
    2923;; Memeoized `make-string'
    3024
    31 (define make-string*
    32   (let ((+strings+ (make-dict eqv?)))
    33     (lambda (len #!optional (ch #\space))
    34       (check-natural-fixnum 'make-string* len)
    35       (check-char 'make-string* ch)
    36       (let loop ((len len) (ch ch))
    37         (if* (dict-ref +strings+ ch)
    38           (or (dict-ref it len)
    39               (let ((str (if (ascii-codepoint? ch) (##sys#make-string len ch)
    40                            (unicode-make-string len ch) ) ) )
    41                 (dict-set! it len str)
    42                 ; dict `it' already member of +strings+
    43                 str ) )
     25(define (make-string* len #!optional (ch #\space))
     26  (check-natural-fixnum 'make-string* len)
     27  (check-char 'make-string* ch)
     28  (*make-string* len ch) )
     29
     30(define *make-string*
     31  (let ((+strings+ (make-hash-table eqv?)))
     32    (lambda (len ch)
     33      (let ((str-hash-table (hash-table-ref/default +strings+ ch #f)))
     34        (if str-hash-table
     35          (or
     36            (hash-table-ref/default str-hash-table len #f)
     37            (let ((str (unicode-make-string len ch)))
     38              (hash-table-set! str-hash-table len str)
     39              ; str-hash-table already member of +strings+
     40              str ) )
    4441          (begin
    45             (dict-update-dict! +strings+ ch)
    46             (loop len ch) ) ) ) ) ) )
     42            (hash-table-set! +strings+ ch (make-hash-table eqv?))
     43            (*make-string* len ch) ) ) ) ) ) )
    4744
    4845) ;module memoized-string
  • release/4/string-utils/tags/1.2.5/string-hexadecimal.scm

    r26403 r34123  
    44(module string-hexadecimal
    55
    6   (;export
    7     string->hex)
     6(;export
     7  string->hex *string->hex)
    88
    9   (import
    10     scheme
    11     chicken
    12     (only lolevel number-of-bytes)
    13     (only to-hex str_to_hex)
    14     (only type-checks check-natural-fixnum check-string))
     9(import scheme chicken)
    1510
    16   (require-library lolevel to-hex type-checks)
     11(import
     12  (only lolevel number-of-bytes)
     13  (only to-hex str_to_hex)
     14  (only type-checks check-natural-fixnum check-string))
     15(require-library lolevel to-hex type-checks)
    1716
    18   (declare
    19     (bound-to-procedure
    20       ##sys#signal-hook))
    21 
    22 ;;
    23 
    24 #;
    25 (define (*bytevector->hex tohex bv start end)
    26   (let ((len (fx- end start)))
    27                 (if (fx= 0 len)
    28                         ""
    29                         (let ((res (make-string (fx* len 2))))
    30                                 (tohex res bv start len)
    31                                 res ) ) ) )
     17(declare
     18  (bound-to-procedure
     19    ##sys#signal-hook))
    3220
    3321;;
     
    3624  (check-string 'string->hex str)
    3725  (check-natural-fixnum 'string->hex start 'start)
    38   (when end (check-natural-fixnum 'string->hex end 'end))
    39   (let ((end (or end (number-of-bytes str))))
     26  (let ((end
     27        (or
     28          (and end (check-natural-fixnum 'string->hex end 'end))
     29          (number-of-bytes str))))
    4030    (unless (<= start end)
    41       (##sys#signal-hook #:bounds-error 'string->hex
    42                          "illegal subvector specification" start end))
    43     (let ((len (fx- end start)))
    44       (if (fx= 0 len)
    45         ""
    46         (let ((res (make-string (fx* len 2))))
    47           (str_to_hex res str start len)
    48           res ) ) ) ) )
     31      (##sys#signal-hook
     32        #:bounds-error 'string->hex
     33        "illegal subvector specification" start end))
     34    (*string->hex str start end) ) )
     35
     36(define (*string->hex str start end)
     37  (let ((len (fx- end start)))
     38    (if (fx= 0 len)
     39      ""
     40      (str_to_hex (make-string (fx* len 2)) str start len) ) ) )
    4941
    5042) ;module string-hexadecimal
  • release/4/string-utils/tags/1.2.5/string-utils.meta

    r27618 r34123  
    1010        (setup-helper "1.5.2")
    1111        (miscmacros "2.9")
    12         (lookup-table "1.13.1")
    1312        (check-errors "1.12.1"))
    1413 (test-depends test)
  • release/4/string-utils/tags/1.2.5/string-utils.scm

    r19894 r34123  
    44(module string-utils ()
    55
    6   (import
    7     scheme chicken)
     6(import scheme chicken)
    87
    9   (reexport
    10     memoized-string
    11     unicode-utils
    12     string-hexadecimal)
     8(reexport
     9  memoized-string
     10  unicode-utils
     11  string-hexadecimal)
    1312
    14   (require-library
    15     memoized-string
    16     unicode-utils
    17     string-hexadecimal)
     13(require-library
     14  memoized-string
     15  unicode-utils
     16  string-hexadecimal)
    1817
    1918) ;module string-utils
  • release/4/string-utils/tags/1.2.5/string-utils.setup

    r27751 r34123  
    55(verify-extension-name "string-utils")
    66
    7 (setup-shared-extension-module 'unicode-utils (extension-version "1.2.4")
     7(setup-shared-extension-module 'unicode-utils (extension-version "1.2.5")
    88  #:inline? #t
    99  #:types? #t
     
    1414    -no-procedure-checks))
    1515
    16 (setup-shared-extension-module 'memoized-string (extension-version "1.2.4")
     16(setup-shared-extension-module 'memoized-string (extension-version "1.2.5")
    1717  #:inline? #t
    1818  #:types? #t
     
    2424    -no-procedure-checks))
    2525
    26 (setup-shared-extension-module 'to-hex (extension-version "1.2.4"))
     26(setup-shared-extension-module 'to-hex (extension-version "1.2.5"))
    2727
    28 (setup-shared-extension-module 'string-hexadecimal (extension-version "1.2.4")
     28(setup-shared-extension-module 'string-hexadecimal (extension-version "1.2.5")
    2929  #:inline? #t
    3030  #:types? #t
     
    3535    -no-procedure-checks))
    3636
    37 (setup-shared-extension-module 'string-utils (extension-version "1.2.4")
     37(setup-shared-extension-module 'string-utils (extension-version "1.2.5")
    3838  #:inline? #t
    3939  #:types? #t
  • release/4/string-utils/tags/1.2.5/to-hex.scm

    r26313 r34123  
    11;;;; to-hex.scm  -*- Hen -*-
    22;;;; Kon Lovett, Sep '10
     3;;;; Kon Lovett, Sep '17
    34
    45(module to-hex
    56
    6   (;export
    7     mem_to_hex
    8     s8vec_to_hex
    9     u8vec_to_hex
    10     blob_to_hex
    11     str_to_hex)
     7(;export
     8  mem_to_hex
     9  s8vec_to_hex
     10  u8vec_to_hex
     11  blob_to_hex
     12  str_to_hex)
    1213
    13   (import
    14     scheme
    15     chicken
    16     foreign)
     14(import scheme)
     15(import chicken foreign)
    1716
    18 ;;
     17;;;
    1918
    2019#>
     
    2423  static char digits[] = "0123456789abcdef";
    2524  in += off;
    26   while (len--) {
     25  while( len-- ) {
    2726    *out++ = digits[ *in >> 4 ];
    2827    *out++ = digits[ *in++ & 0x0f ];
     
    3130<#
    3231
    33 (define str_to_hex
     32(define C_str_to_hex
    3433  (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-scheme-pointer int int))
    3534
    36 (define blob_to_hex
     35(define C_blob_to_hex
    3736  (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-blob int int))
    3837
    39 (define u8vec_to_hex
     38(define C_u8vec_to_hex
    4039  (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-u8vector int int))
    4140
    42 (define s8vec_to_hex
    43   (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-s8vector int int))
     41(define C_s8vec_to_hex
     42  (foreign-lambda*
     43      void
     44      ((nonnull-scheme-pointer out) (nonnull-s8vector in) (int off) (int len))
     45    "bv_to_hex(out, (uint8_t *)in, off, len);"))
    4446
    45 (define mem_to_hex
     47(define C_mem_to_hex
    4648  (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-c-pointer int int))
    4749
     50;;;
     51
     52(define (str_to_hex out in off len)
     53  (C_str_to_hex out in off len)
     54  out )
     55
     56(define (blob_to_hex out in off len)
     57  (C_blob_to_hex out in off len)
     58  out )
     59
     60(define (u8vec_to_hex out in off len)
     61  (C_u8vec_to_hex out in off len)
     62  out )
     63
     64(define (s8vec_to_hex out in off len)
     65  (C_s8vec_to_hex out in off len)
     66  out )
     67
     68(define (mem_to_hex out in off len)
     69  (C_mem_to_hex out in off len)
     70  out )
     71
    4872) ;module to-hex
  • release/4/string-utils/tags/1.2.5/unicode-utils.scm

    r27751 r34123  
    88(module unicode-utils
    99
    10   (;export
    11     ascii-codepoint?
    12     unicode-char->string
    13     unicode-string
    14     unicode-make-string
    15     unicode-surrogate?
    16     unicode-surrogates->codepoint)
     10(;export
     11  ascii-codepoint?
     12  unicode-char->string
     13  unicode-string
     14  unicode-make-string *unicode-make-string
     15  unicode-surrogate?
     16  unicode-surrogates->codepoint)
    1717
    18   (import
    19     scheme
    20     chicken
    21     (only data-structures reverse-string-append)
    22     (only type-checks
    23       check-natural-fixnum check-char))
     18(import scheme chicken)
    2419
    25   (require-library
    26         srfi-13
    27         type-checks)
     20(import
     21  (only srfi-1 make-list)
     22  (only srfi-13 string-concatenate )
     23  (only type-checks check-natural-fixnum check-char))
     24(require-library srfi-1 srfi-13 type-checks)
    2825
    29   (declare
    30     (bound-to-procedure
    31       ##sys#string-append
    32       ##sys#char->utf8-string
    33       ##sys#unicode-surrogate?
    34       ##sys#surrogates->codepoint))
     26(declare
     27  (bound-to-procedure
     28    ##sys#string-append
     29    ##sys#char->utf8-string
     30    ##sys#unicode-surrogate?
     31    ##sys#surrogates->codepoint))
    3532
    36 ;; SImple UTF 8
     33;; Simple UTF 8
    3734
    3835(define (ascii-codepoint? ch)
    3936  (let ((x (char->integer (check-char 'ascii-codepoint? ch))))
    40     (and (fx<= 0 x) (fx<= x #x7F)) ) )
     37    (and (fx<= 0 x) (fx<= x #x7f)) ) )
    4138
    4239(define (unicode-char->string ch)
     
    4643(define (unicode-string . chs)
    4744  (cond
    48     ((null? chs)        "")
    49     ((null? (cdr chs))  (unicode-char->string (car chs)))
     45    ((null? chs)
     46      "" )
     47    ((null? (cdr chs))
     48      (unicode-char->string (car chs)) )
    5049    (else
    51       (let loop ((chs chs) (ls '()))
    52         (if (null? chs)
    53             (reverse-string-append ls)
    54                 (loop (cdr chs) (cons (unicode-char->string (car chs)) ls) ) ) ) ) ) )
     50      (string-concatenate (map unicode-char->string chs)) ) ) )
    5551
    56 ;inefficient
    5752(define (unicode-make-string len #!optional (fill #\space))
    58   (check-natural-fixnum 'unicode-make-string len)
    59   (check-char 'unicode-make-string fill)
    60   (cond
    61     ((fx= 0 len)              "")
    62     ((ascii-codepoint? fill)  (##sys#make-string len fill))
    63     (else
    64       (let ((fill (##sys#char->utf8-string fill)))
    65         (let loop ((len len) (ls '()))
    66           (if (fx= 0 len)
    67               (reverse-string-append ls)
    68               (loop (fx- len 1) (cons fill ls)) ) ) ) ) ) )
     53  (*unicode-make-string
     54    (check-natural-fixnum 'unicode-make-string len)
     55    (check-char 'unicode-make-string fill)) )
    6956
    7057(define (unicode-surrogate? n)
     
    7663    (check-natural-fixnum 'unicode-surrogates->codepoint lo "low")) )
    7764
     65;inefficient
     66(define (*unicode-make-string len fill)
     67  (cond
     68    ((fx= 0 len)
     69      "" )
     70    ((ascii-codepoint? fill)
     71      (##sys#make-string len fill) )
     72    (else
     73      (string-concatenate (make-list len (##sys#char->utf8-string fill))) ) ) )
     74
    7875
    7976) ;module unicode-utils
  • release/4/string-utils/trunk/memoized-string.scm

    r19894 r34123  
    44(module memoized-string
    55
    6   (;export
    7     make-string*)
     6(;export
     7  make-string* *make-string*)
    88
    9   (import
    10     scheme
    11     chicken
    12     (only lookup-table
    13       make-dict dict-ref dict-set! dict-update-dict!)
    14     (only miscmacros
    15       if*)
    16     (only unicode-utils
    17       ascii-codepoint? unicode-make-string)
    18     (only type-checks
    19       check-natural-fixnum check-char))
     9(import scheme chicken)
    2010
    21   (require-library
    22     miscmacros lookup-table type-checks
    23     unicode-utils)
    24 
    25   (declare
    26     (bound-to-procedure
    27       ##sys#make-string))
     11(import
     12  (only srfi-69
     13    make-hash-table hash-table-ref/default hash-table-set!)
     14  (only unicode-utils
     15    ascii-codepoint? unicode-make-string)
     16  (only type-checks
     17    check-natural-fixnum check-char))
     18(require-library
     19  srfi-69
     20  unicode-utils
     21  type-checks)
    2822
    2923;; Memeoized `make-string'
    3024
    31 (define make-string*
    32   (let ((+strings+ (make-dict eqv?)))
    33     (lambda (len #!optional (ch #\space))
    34       (check-natural-fixnum 'make-string* len)
    35       (check-char 'make-string* ch)
    36       (let loop ((len len) (ch ch))
    37         (if* (dict-ref +strings+ ch)
    38           (or (dict-ref it len)
    39               (let ((str (if (ascii-codepoint? ch) (##sys#make-string len ch)
    40                            (unicode-make-string len ch) ) ) )
    41                 (dict-set! it len str)
    42                 ; dict `it' already member of +strings+
    43                 str ) )
     25(define (make-string* len #!optional (ch #\space))
     26  (check-natural-fixnum 'make-string* len)
     27  (check-char 'make-string* ch)
     28  (*make-string* len ch) )
     29
     30(define *make-string*
     31  (let ((+strings+ (make-hash-table eqv?)))
     32    (lambda (len ch)
     33      (let ((str-hash-table (hash-table-ref/default +strings+ ch #f)))
     34        (if str-hash-table
     35          (or
     36            (hash-table-ref/default str-hash-table len #f)
     37            (let ((str (unicode-make-string len ch)))
     38              (hash-table-set! str-hash-table len str)
     39              ; str-hash-table already member of +strings+
     40              str ) )
    4441          (begin
    45             (dict-update-dict! +strings+ ch)
    46             (loop len ch) ) ) ) ) ) )
     42            (hash-table-set! +strings+ ch (make-hash-table eqv?))
     43            (*make-string* len ch) ) ) ) ) ) )
    4744
    4845) ;module memoized-string
  • release/4/string-utils/trunk/string-hexadecimal.scm

    r26403 r34123  
    44(module string-hexadecimal
    55
    6   (;export
    7     string->hex)
     6(;export
     7  string->hex *string->hex)
    88
    9   (import
    10     scheme
    11     chicken
    12     (only lolevel number-of-bytes)
    13     (only to-hex str_to_hex)
    14     (only type-checks check-natural-fixnum check-string))
     9(import scheme chicken)
    1510
    16   (require-library lolevel to-hex type-checks)
     11(import
     12  (only lolevel number-of-bytes)
     13  (only to-hex str_to_hex)
     14  (only type-checks check-natural-fixnum check-string))
     15(require-library lolevel to-hex type-checks)
    1716
    18   (declare
    19     (bound-to-procedure
    20       ##sys#signal-hook))
    21 
    22 ;;
    23 
    24 #;
    25 (define (*bytevector->hex tohex bv start end)
    26   (let ((len (fx- end start)))
    27                 (if (fx= 0 len)
    28                         ""
    29                         (let ((res (make-string (fx* len 2))))
    30                                 (tohex res bv start len)
    31                                 res ) ) ) )
     17(declare
     18  (bound-to-procedure
     19    ##sys#signal-hook))
    3220
    3321;;
     
    3624  (check-string 'string->hex str)
    3725  (check-natural-fixnum 'string->hex start 'start)
    38   (when end (check-natural-fixnum 'string->hex end 'end))
    39   (let ((end (or end (number-of-bytes str))))
     26  (let ((end
     27        (or
     28          (and end (check-natural-fixnum 'string->hex end 'end))
     29          (number-of-bytes str))))
    4030    (unless (<= start end)
    41       (##sys#signal-hook #:bounds-error 'string->hex
    42                          "illegal subvector specification" start end))
    43     (let ((len (fx- end start)))
    44       (if (fx= 0 len)
    45         ""
    46         (let ((res (make-string (fx* len 2))))
    47           (str_to_hex res str start len)
    48           res ) ) ) ) )
     31      (##sys#signal-hook
     32        #:bounds-error 'string->hex
     33        "illegal subvector specification" start end))
     34    (*string->hex str start end) ) )
     35
     36(define (*string->hex str start end)
     37  (let ((len (fx- end start)))
     38    (if (fx= 0 len)
     39      ""
     40      (str_to_hex (make-string (fx* len 2)) str start len) ) ) )
    4941
    5042) ;module string-hexadecimal
  • release/4/string-utils/trunk/string-utils.meta

    r27618 r34123  
    1010        (setup-helper "1.5.2")
    1111        (miscmacros "2.9")
    12         (lookup-table "1.13.1")
    1312        (check-errors "1.12.1"))
    1413 (test-depends test)
  • release/4/string-utils/trunk/string-utils.scm

    r19894 r34123  
    44(module string-utils ()
    55
    6   (import
    7     scheme chicken)
     6(import scheme chicken)
    87
    9   (reexport
    10     memoized-string
    11     unicode-utils
    12     string-hexadecimal)
     8(reexport
     9  memoized-string
     10  unicode-utils
     11  string-hexadecimal)
    1312
    14   (require-library
    15     memoized-string
    16     unicode-utils
    17     string-hexadecimal)
     13(require-library
     14  memoized-string
     15  unicode-utils
     16  string-hexadecimal)
    1817
    1918) ;module string-utils
  • release/4/string-utils/trunk/string-utils.setup

    r27751 r34123  
    55(verify-extension-name "string-utils")
    66
    7 (setup-shared-extension-module 'unicode-utils (extension-version "1.2.4")
     7(setup-shared-extension-module 'unicode-utils (extension-version "1.2.5")
    88  #:inline? #t
    99  #:types? #t
     
    1414    -no-procedure-checks))
    1515
    16 (setup-shared-extension-module 'memoized-string (extension-version "1.2.4")
     16(setup-shared-extension-module 'memoized-string (extension-version "1.2.5")
    1717  #:inline? #t
    1818  #:types? #t
     
    2424    -no-procedure-checks))
    2525
    26 (setup-shared-extension-module 'to-hex (extension-version "1.2.4"))
     26(setup-shared-extension-module 'to-hex (extension-version "1.2.5"))
    2727
    28 (setup-shared-extension-module 'string-hexadecimal (extension-version "1.2.4")
     28(setup-shared-extension-module 'string-hexadecimal (extension-version "1.2.5")
    2929  #:inline? #t
    3030  #:types? #t
     
    3535    -no-procedure-checks))
    3636
    37 (setup-shared-extension-module 'string-utils (extension-version "1.2.4")
     37(setup-shared-extension-module 'string-utils (extension-version "1.2.5")
    3838  #:inline? #t
    3939  #:types? #t
  • release/4/string-utils/trunk/to-hex.scm

    r26313 r34123  
    11;;;; to-hex.scm  -*- Hen -*-
    22;;;; Kon Lovett, Sep '10
     3;;;; Kon Lovett, Sep '17
    34
    45(module to-hex
    56
    6   (;export
    7     mem_to_hex
    8     s8vec_to_hex
    9     u8vec_to_hex
    10     blob_to_hex
    11     str_to_hex)
     7(;export
     8  mem_to_hex
     9  s8vec_to_hex
     10  u8vec_to_hex
     11  blob_to_hex
     12  str_to_hex)
    1213
    13   (import
    14     scheme
    15     chicken
    16     foreign)
     14(import scheme)
     15(import chicken foreign)
    1716
    18 ;;
     17;;;
    1918
    2019#>
     
    2423  static char digits[] = "0123456789abcdef";
    2524  in += off;
    26   while (len--) {
     25  while( len-- ) {
    2726    *out++ = digits[ *in >> 4 ];
    2827    *out++ = digits[ *in++ & 0x0f ];
     
    3130<#
    3231
    33 (define str_to_hex
     32(define C_str_to_hex
    3433  (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-scheme-pointer int int))
    3534
    36 (define blob_to_hex
     35(define C_blob_to_hex
    3736  (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-blob int int))
    3837
    39 (define u8vec_to_hex
     38(define C_u8vec_to_hex
    4039  (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-u8vector int int))
    4140
    42 (define s8vec_to_hex
    43   (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-s8vector int int))
     41(define C_s8vec_to_hex
     42  (foreign-lambda*
     43      void
     44      ((nonnull-scheme-pointer out) (nonnull-s8vector in) (int off) (int len))
     45    "bv_to_hex(out, (uint8_t *)in, off, len);"))
    4446
    45 (define mem_to_hex
     47(define C_mem_to_hex
    4648  (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-c-pointer int int))
    4749
     50;;;
     51
     52(define (str_to_hex out in off len)
     53  (C_str_to_hex out in off len)
     54  out )
     55
     56(define (blob_to_hex out in off len)
     57  (C_blob_to_hex out in off len)
     58  out )
     59
     60(define (u8vec_to_hex out in off len)
     61  (C_u8vec_to_hex out in off len)
     62  out )
     63
     64(define (s8vec_to_hex out in off len)
     65  (C_s8vec_to_hex out in off len)
     66  out )
     67
     68(define (mem_to_hex out in off len)
     69  (C_mem_to_hex out in off len)
     70  out )
     71
    4872) ;module to-hex
  • release/4/string-utils/trunk/unicode-utils.scm

    r27751 r34123  
    88(module unicode-utils
    99
    10   (;export
    11     ascii-codepoint?
    12     unicode-char->string
    13     unicode-string
    14     unicode-make-string
    15     unicode-surrogate?
    16     unicode-surrogates->codepoint)
     10(;export
     11  ascii-codepoint?
     12  unicode-char->string
     13  unicode-string
     14  unicode-make-string *unicode-make-string
     15  unicode-surrogate?
     16  unicode-surrogates->codepoint)
    1717
    18   (import
    19     scheme
    20     chicken
    21     (only data-structures reverse-string-append)
    22     (only type-checks
    23       check-natural-fixnum check-char))
     18(import scheme chicken)
    2419
    25   (require-library
    26         srfi-13
    27         type-checks)
     20(import
     21  (only srfi-1 make-list)
     22  (only srfi-13 string-concatenate )
     23  (only type-checks check-natural-fixnum check-char))
     24(require-library srfi-1 srfi-13 type-checks)
    2825
    29   (declare
    30     (bound-to-procedure
    31       ##sys#string-append
    32       ##sys#char->utf8-string
    33       ##sys#unicode-surrogate?
    34       ##sys#surrogates->codepoint))
     26(declare
     27  (bound-to-procedure
     28    ##sys#string-append
     29    ##sys#char->utf8-string
     30    ##sys#unicode-surrogate?
     31    ##sys#surrogates->codepoint))
    3532
    36 ;; SImple UTF 8
     33;; Simple UTF 8
    3734
    3835(define (ascii-codepoint? ch)
    3936  (let ((x (char->integer (check-char 'ascii-codepoint? ch))))
    40     (and (fx<= 0 x) (fx<= x #x7F)) ) )
     37    (and (fx<= 0 x) (fx<= x #x7f)) ) )
    4138
    4239(define (unicode-char->string ch)
     
    4643(define (unicode-string . chs)
    4744  (cond
    48     ((null? chs)        "")
    49     ((null? (cdr chs))  (unicode-char->string (car chs)))
     45    ((null? chs)
     46      "" )
     47    ((null? (cdr chs))
     48      (unicode-char->string (car chs)) )
    5049    (else
    51       (let loop ((chs chs) (ls '()))
    52         (if (null? chs)
    53             (reverse-string-append ls)
    54                 (loop (cdr chs) (cons (unicode-char->string (car chs)) ls) ) ) ) ) ) )
     50      (string-concatenate (map unicode-char->string chs)) ) ) )
    5551
    56 ;inefficient
    5752(define (unicode-make-string len #!optional (fill #\space))
    58   (check-natural-fixnum 'unicode-make-string len)
    59   (check-char 'unicode-make-string fill)
    60   (cond
    61     ((fx= 0 len)              "")
    62     ((ascii-codepoint? fill)  (##sys#make-string len fill))
    63     (else
    64       (let ((fill (##sys#char->utf8-string fill)))
    65         (let loop ((len len) (ls '()))
    66           (if (fx= 0 len)
    67               (reverse-string-append ls)
    68               (loop (fx- len 1) (cons fill ls)) ) ) ) ) ) )
     53  (*unicode-make-string
     54    (check-natural-fixnum 'unicode-make-string len)
     55    (check-char 'unicode-make-string fill)) )
    6956
    7057(define (unicode-surrogate? n)
     
    7663    (check-natural-fixnum 'unicode-surrogates->codepoint lo "low")) )
    7764
     65;inefficient
     66(define (*unicode-make-string len fill)
     67  (cond
     68    ((fx= 0 len)
     69      "" )
     70    ((ascii-codepoint? fill)
     71      (##sys#make-string len fill) )
     72    (else
     73      (string-concatenate (make-list len (##sys#char->utf8-string fill))) ) ) )
     74
    7875
    7976) ;module unicode-utils
Note: See TracChangeset for help on using the changeset viewer.