Changeset 38017 in project


Ignore:
Timestamp:
12/14/19 05:12:02 (2 months ago)
Author:
Kon Lovett
Message:

rm fx & use types

Location:
release/5/string-utils/trunk
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • release/5/string-utils/trunk/memoized-string.scm

    r35791 r38017  
    1717(import scheme
    1818  (chicken base)
    19   (chicken fixnum)
    2019  (chicken type)
    2120  (only srfi-1 every)
     
    4847(define (string+ . chars)
    4948  (let ((len (length chars)))
    50     (if (fx= 0 len)
     49    (if (= 0 len)
    5150      (*make-string+ 0 #f "")
    5251      (begin
     
    9392        (let* (
    9493          (len (string-length str) )
    95           (ch (and (not (fx= 0 len)) (string-ref str 0)) ) )
     94          (ch (and (not (= 0 len)) (string-ref str 0)) ) )
    9695          (*make-string+ len ch str) ) )
    9796      ((len ch)
    9897        (*make-string+ len ch (delay (generic-make-string len ch))) )
    9998      ((len ch str)
    100         (if (fx= 0 len)
     99        (if (= 0 len)
    101100          *empty-string*
    102101          (ensure-string-entry len ch str) ) ) ) ) )
  • release/5/string-utils/trunk/string-hexadecimal.scm

    r35834 r38017  
    1717(import scheme
    1818  (chicken base)
    19   (chicken fixnum)
    2019  (chicken type)
    2120  (chicken foreign)
     
    2625;;;
    2726
    28 (define-inline (fxzero? x)
    29   (fx= 0 x) )
    30 
    31 ;;;
    32 
    3327(define (check-subvector-indexes loc start end)
    3428  (unless
    35     (fx<=
     29    (<=
    3630      (check-natural-fixnum loc start 'start)
    3731      (check-natural-fixnum loc end 'end))
     
    4337;
    4438(define (string->hex str #!optional (start 0) (end #f))
    45   (check-string 'string->hex str)
    46   (let ((end (or end (number-of-bytes str))))
     39  (let* (
     40    (len (number-of-bytes (check-string 'string->hex str)))
     41    (end (or end len)) )
    4742    (check-subvector-indexes 'string->hex start end)
    4843    (*string->hex str start end) ) )
     
    5146;
    5247(define (hex->string str #!optional (start 0) (end #f))
    53   (let ((len (number-of-bytes (check-string 'hex->string str))))
    54     (unless (fxzero? (fxmod len 2))
     48  (let* (
     49    (len (number-of-bytes (check-string 'hex->string str)))
     50    (end (or end len)) )
     51    (unless (zero? (modulo end 2))
    5552      (error 'hex->string "too few characters" str) )
    56     (let ((end (or end len)))
    57       (check-subvector-indexes 'hex->string start end)
    58       (*hex->string str start end) ) ) )
     53    (check-subvector-indexes 'hex->string start end)
     54    (*hex->string str start end) ) )
    5955
    6056;;
     
    6359;
    6460(define (*string->hex str start end)
    65   (let ((len (fx- end start)))
    66     (if (fxzero? len)
     61  (let (
     62    (len (- end start)) )
     63    (if (zero? len)
    6764      ""
    68       (str_to_hex (##sys#make-string (fx* len 2)) str start len) ) ) )
     65      (str_to_hex (##sys#make-string (* len 2)) str start len) ) ) )
    6966
    7067(: *hex->string (string fixnum fixnum --> string))
    7168;
    7269(define (*hex->string str start end)
    73   (let ((len (fx- end start)))
    74     (if (fxzero? len)
     70  (let (
     71    (len (- end start)) )
     72    (if (zero? len)
    7573      ""
    76       (hex_to_str (##sys#make-string (fx/ len 2)) str start len) ) ) )
     74      (hex_to_str (##sys#make-string (quotient len 2)) str start len) ) ) )
    7775
    7876#|
    79 (use
     77(import
    8078  (only (srfi 1) drop drop-right)
    8179  (only (srfi 13) string-pad string-concatenate  reverse-list->string))
    8280
     81(define ( ch)
     82  (string-pad (number->string (char->integer ch) 16) 2 #\0) )
     83
    8384(define (*string->hex str start end)
    84   (let* ((ls (string->list str) )
    85          (ls (drop ls start) )
    86          (strlen (string-length str) )
    87          (ls (drop-right ls (fx- strlen end)) ) )
     85  (let* (
     86    (ls (string->list str))
     87    (ls (drop ls start))
     88    (strlen (string-length str))
     89    (ls (drop-right ls (- strlen end))) )
    8890    (string-concatenate
    8991      (map
     
    9395
    9496(define (*hex->string str)
    95   (let ((len (string-length str)))
     97  (let (
     98    (len (string-length str)) )
    9699    (let loop ((i 0) (ls '()))
    97       (if (fx<= len i)
     100      (if (<= len i)
    98101        (reverse-list->string ls)
    99         (let ((ni (fx+ i 2) ))
     102        (let (
     103          (ni (+ i 2)) )
    100104          (loop ni (cons (integer->char (string->number (substring str i ni) 16)) ls)) ) ) ) ) )
    101105|#
  • release/5/string-utils/trunk/string-interpolation-body.scm

    r37865 r38017  
    1010(: string-interpolate/sanity (string #!rest --> list))
    1111;
    12 (define (string-interpolate/sanity str #!key (eval-tag #\#) (insane #f))
    13   (let ((strp (open-input-string str)))
    14     ;objs - stack of objects (string components)
    15     ;chrs - stack of chars (substring components)
    16     (let advance ((objs '()) (chrs #f))
     12(define (string-interpolate/sanity str #!key (eval-tag #\#) (bracing? #f))
     13  (let (
     14    (inp (open-input-string str)) )
     15    (let advance (
     16      ;stack of objects (string components)
     17      (objs '())
     18      ;stack of chars (substring components)
     19      (chrs #f) )
    1720      ;
    1821      ;"inject" char in front
     
    3134      ;
    3235      ;in the body or not
    33       (let ((ch (read-char strp)))
     36      (let (
     37        (ch (read-char inp)) )
    3438        (cond
    3539          ;
     
    4145          ((char=? eval-tag ch)
    4246            ;lookahead 1
    43             (let ((ch (peek-char strp)))
     47            (let (
     48              (ch (peek-char inp)) )
    4449              (cond
    4550                ;
     
    5055                ;read tag : <tag><tag> -> <tag>
    5156                ((char=? eval-tag ch)
    52                   (advance objs (push-char (read-char strp))) )
     57                  (advance objs (push-char (read-char inp))) )
    5358                ;
    5459                ;WART read wrapped expression
    55                 ((and insane (char=? #\{ ch))
     60                ((and bracing? (char=? #\{ ch))
    5661                  ;!!! we do not test for #\} !!!
    57                   (advance (push-object (car (read strp))) #f) )
     62                  (advance (push-object (car (read inp))) #f) )
    5863                ;
    5964                ;read expression
    6065                (else
    61                   (advance (push-object (read strp)) #f) ) ) ) )
     66                  (advance (push-object (read inp)) #f) ) ) ) )
    6267          ;
    6368          ;ordinary char!
     
    6974(define (string-interpolate str #!key (eval-tag #\#))
    7075  (parameterize ((parentheses-synonyms #t))
    71     (string-interpolate/sanity str #:eval-tag eval-tag #:insane #t) ) )
     76    (string-interpolate/sanity str #:eval-tag eval-tag #:bracing? #t) ) )
  • release/5/string-utils/trunk/string-interpolation-syntax.scm

    r37858 r38017  
    2525      (let (
    2626        (proc (if (procedure? proc) proc identity)) )
    27         (lambda (rest-port)
     27        (lambda (bodyp)
    2828          (call-with-input-string "\""
    29             (lambda (head-port)
     29            (lambda (quotep)
    3030              (let* (
    31                 (port (make-concatenated-port head-port rest-port))
    32                 (str (read port)) )
     31                ;forms [(") (body...")] so read as "...body..."
     32                (stringp (make-concatenated-port quotep bodyp))
     33                (str (read stringp)) )
    3334                (proc str) ) ) ) ) ) ) ) )
    3435
  • release/5/string-utils/trunk/string-utils.scm

    r35810 r38017  
    1212(import scheme
    1313  (chicken base)
    14   (chicken fixnum)
    1514  (chicken sort)
    1615  (chicken type)
     
    1817  (only (srfi 13) string-null? string-take string-prefix-length)
    1918  (only memoized-string make-string+)
    20   (only type-checks check-char check-string check-fixnum ))
     19  (only type-checks check-char check-string check-fixnum))
    2120
    2221;;
     
    3029(define (string-longest-common-prefix cand others)
    3130  ;
    32   (define (prelen item)
    33     (string-longest-common-prefix-length cand item) )
     31  (define (prelength-tag item)
     32    (cons (string-longest-common-prefix-length cand item) item) )
     33  ;
     34  (define (prelength-tag< a b)
     35    (assume (
     36      (a (pair fixnum string))
     37      (b (pair fixnum string)) )
     38      (> (car a) (car a)) ) )
     39  ;
     40  (define (prelength-coalesced< a b)
     41    (assume (
     42      (a (pair fixnum list))
     43      (b (pair fixnum list)) )
     44      (if (= (car a) (car b))
     45        (> (length (cdr a)) (length (cdr b)))
     46        (> (car a) (car b))) ) )
    3447  ;
    3548  (let* (
    3649    (cells
    37       (map (lambda (item) (cons (prelen item) item)) others))
     50      (map prelength-tag others))
    3851    (cells
    39       (sort cells (lambda (a b) (fx> (car a) (car b)))))
     52      (sort cells prelength-tag<))
    4053    (coalesced
    4154      (foldl
    4255        (lambda (coalesced cell)
    43           (let* (
    44             (len (car cell))
    45             (str (cdr cell))
    46             (strs `(,str)) )
    47             (if (null? coalesced)
    48               (cons (cons len strs) coalesced)
    49               (let (
    50                 (coalesced-cell (car coalesced)) )
    51                 (if (fx= len (car coalesced-cell))
    52                   ;share same
    53                   (begin
    54                     (set-cdr! coalesced-cell (append! strs (cdr coalesced-cell)))
    55                     coalesced)
    56                   ;changing of the guard
    57                   (cons (cons len strs) coalesced) ) ) ) ) )
     56          (assume (
     57            (cell (pair fixnum string)) )
     58            (let* (
     59              (len (car cell))
     60              (str (cdr cell))
     61              (strs `(,str)) )
     62              (if (null? coalesced)
     63                (cons (cons len strs) coalesced)
     64                (let (
     65                  (coalesced-cell (car coalesced)) )
     66                  (if (= len (car coalesced-cell))
     67                    ;share same
     68                    (begin
     69                      (set-cdr! coalesced-cell (append! strs (cdr coalesced-cell)))
     70                      coalesced)
     71                    ;changing of the guard
     72                    (cons (cons len strs) coalesced) ) ) ) ) ) )
    5873        '()
    5974        cells))
    6075    (coalesced
    61       (sort
    62         coalesced
    63         (lambda (a b)
    64           (if (fx= (car a) (car b))
    65             (fx> (length (cdr a)) (length (cdr b)))
    66             (fx> (car a) (car b)))))) )
     76      (sort coalesced prelength-coalesced<)) )
    6777    ;longest
    6878    (if (null? coalesced)
     
    8191    (if (null? strs)
    8292      pres
    83       (let ((pre (string-longest-common-prefix (car strs) (cdr strs))))
    84         (let (
    85           (pres
    86             (if (or (not pre) (string-null? pre))
    87               pres
    88               (cons pre pres))) )
    89           (loop (cdr strs) pres) ) ) ) ) )
     93      (let* (
     94        (pre (string-longest-common-prefix (car strs) (cdr strs)))
     95        (pres
     96          (if (or (not pre) (string-null? pre))
     97            pres
     98            (cons pre pres))) )
     99          (loop (cdr strs) pres) ) ) ) )
    90100
    91101;;
     
    96106  (let (
    97107    (rem
    98       (fx-
     108      (-
    99109        (check-fixnum 'string-fixed-length n)
    100110        (string-length (check-string 'string-fixed-length s)))) )
     
    102112      (string-append s (make-string+ rem (check-char 'string-fixed-length pad-char)))
    103113      (let (
    104         (lim (fx- n (string-length (check-string 'string-fixed-length trailing)))) )
     114        (lim (- n (string-length (check-string 'string-fixed-length trailing)))) )
    105115        (if (positive? lim)
    106116          (string-append (substring s 0 lim) trailing)
  • release/5/string-utils/trunk/unicode-utils.scm

    r37677 r38017  
    1818(;export
    1919  ascii-codepoint?
     20  unicode-surrogate?
    2021  unicode-char->string
    2122  unicode-string *unicode-string
    2223  generic-make-string
    2324  unicode-make-string *unicode-make-string
    24   unicode-surrogate?
    2525  unicode-surrogates->codepoint)
    2626
    2727(import scheme
    2828  (chicken base)
    29   (chicken fixnum)
    3029  (chicken type)
    3130  (only srfi-1 every make-list)
     
    4140  (and
    4241    (char? ch)
    43     (let ((x (char->integer ch)))
    44       ;[1 7f] = (1 80)
    45       (and (fx< 0 x) (fx< x #x80)) ) ) )
     42    (<= 0 (char->integer ch) #x7f) ) )
     43
     44(: unicode-surrogate? (* -> boolean : fixnum))
     45;
     46(define (unicode-surrogate? n)
     47  (and
     48    (fixnum? n)
     49    (##sys#unicode-surrogate? n) ) )
    4650
    4751(: unicode-char->string (char -> string))
     
    5963      (##sys#char->utf8-string (car chs)) )
    6064    (else
    61       (let ((chs (map ##sys#char->utf8-string chs)))
     65      (let (
     66        (chs (map ##sys#char->utf8-string chs)) )
    6267        (##sys#fragments->string
    63           (foldl (lambda (l s) (fx+ l (##sys#size s))) 0 chs)
     68          (foldl (lambda (l s) (+ l (the fixnum (##sys#size s)))) 0 chs)
    6469          chs) ) ) ) )
    6570
     
    8085(define (*unicode-make-string len fill)
    8186  (cond
    82     ((fx= 0 len)
     87    ((= 0 len)
    8388      "" )
    8489    ;ascii-codepoint < char
     
    97102(define generic-make-string unicode-make-string)
    98103
    99 (: unicode-surrogate? (* -> boolean : fixnum))
    100 ;
    101 (define (unicode-surrogate? n)
    102   (and
    103     (fixnum? n)
    104     (##sys#unicode-surrogate? n) ) )
    105 
    106104(: unicode-surrogates->codepoint (fixnum fixnum -> (or boolean fixnum)))
    107105;
Note: See TracChangeset for help on using the changeset viewer.