Changeset 12613 in project


Ignore:
Timestamp:
11/27/08 20:38:13 (11 years ago)
Author:
Kon Lovett
Message:

Fix for compiler rewrite of some string operations to ##sys operations. Made utf8-lolevel unsafe.

Location:
release/3/utf8
Files:
18 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/3/utf8/tags/2.0.5/byte-string-srfi-13.scm

    r9961 r12613  
    1818
    1919(declare
    20   (usual-integrations)
    2120  (export
    2221    byte-string-upcase!
  • release/3/utf8/tags/2.0.5/byte-string.scm

    r11873 r12613  
    44;; BSD-style license: http://synthcode.com/license.txt
    55
    6 (require-extension regex)
     6(require-extension data-structures extras regex)
    77
    88; (defun export-all ()
     
    1818
    1919(declare
    20   (usual-integrations)
    2120  (export
    2221    small-char-alphabetic?
  • release/3/utf8/tags/2.0.5/tests/run.scm

    r9873 r12613  
    88(define *fail* 0)
    99
     10#;
    1011(define-macro (test form . opt)
    1112  (if (pair? opt)
     
    2324      `(begin (write ',form) (display " => ") (write ,form) (newline))))
    2425
     26(define (exn-condition->list cnd)
     27  (list
     28    ((condition-property-accessor 'exn 'location #f) cnd)
     29    ((condition-property-accessor 'exn 'message #f) cnd)
     30    ((condition-property-accessor 'exn 'arguments #f) cnd)) )
     31
     32(define-macro (test form . opt)
     33  (let ((res (gensym)) (expect (gensym)))
     34    `(let ((,res (condition-case ,form
     35                   (exn () (list 'error ',(gensym) "exception" (exn-condition->list exn)))))
     36           (,expect ,(optional opt #t)))
     37       (if (equal? ,res ,expect)
     38           (begin
     39             (set! *pass* (+ 1 *pass*))
     40             (display "[ OK ] ") (write ',form) (display " => ") (write ,res) (newline))
     41           (begin
     42             (set! *fail* (+ 1 *fail*))
     43             (display "[FAIL] ") (write ',form) (display " => ") (write ,res)
     44             (display " [expected ") (write ,expect) (display "]") (newline))))))
     45
    2546;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    2647;; R5RS
     
    241262
    242263(test (integer? (string-hash "abc")))
    243 (test (integer? (string-hash-ci "abc")))
     264(test (integer? (string-ci-hash "abc")))
    244265
    245266(test (not (= (string-hash "abc") (string-hash "abd"))))
    246 (test (= (string-hash-ci "abc") (string-hash-ci "aBc") (string-hash-ci "ABC")))
     267(test (= (string-ci-hash "abc") (string-ci-hash "aBc") (string-ci-hash "ABC")))
    247268
    248269(test (= (string-hash "いうえ" #xFFFF)
  • release/3/utf8/tags/2.0.5/unicode-char-sets.scm

    r9872 r12613  
    66  ((and chicken compiling)
    77   (declare
     8     (fixnum) ; no chars above 2^21
     9     (usual-integrations)
     10     (no-bound-checks)
     11     (no-procedure-checks)
    812     (export
    913       char-set:alphabetic
  • release/3/utf8/tags/2.0.5/utf8-case-map.scm

    r9872 r12613  
    1212;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1313
    14 (declare (fixnum)) ; no chars above 2^21
     14(declare
     15  (fixnum) ; no chars above 2^21
     16  (usual-integrations)
     17  (no-bound-checks)
     18  (no-procedure-checks) )
    1519
    1620(define-extension utf8-case-map
  • release/3/utf8/tags/2.0.5/utf8-lolevel.scm

    r9872 r12613  
    1414;; 'sp-' is a string-pointer function referring to offsets.
    1515
     16;; Uses ##sys#become! since all types are correct at runtime.
     17;;
     18;; Assumes string-length, string-ref & string-set! are rewritten by the compiler.
     19
    1620(require-extension byte-string)
    1721
     
    1923  (fixnum) ; no chars above 2^21
    2024  (usual-integrations)
     25  (no-bound-checks)
     26  (no-procedure-checks)
    2127  (export
    2228    ;; utils
     
    5056  (let ((limit (string-length str)))
    5157    (let loop ((i 0))
    52       (if (= i limit)
    53         #t
    54         (and (> 128 (string-int-ref str i))
    55              (loop (+ i 1)))))))
     58      (or (= i limit)
     59          (and (> 128 (string-int-ref str i))
     60               (loop (+ i 1)))))))
    5661
    5762;; from SRFI-33, useful in splitting up the bit patterns used to
     
    147152         (b1 (utf8-index->offset s start))
    148153         (opt2 (if (pair? opt) (cdr opt) '())))
    149     (if (pair? opt2)
    150       (let ((limit (string-length s))
    151             (end (car opt2)))
    152         (let lp ((b2 b1) (count start))
    153           (cond
    154             ((= count end) (proc s b1 b2))
    155             ((> b2 limit) (error "index out of range" s end))
    156             (else
    157              (lp (+ b2 (utf8-start-byte->length (string-int-ref s b2)))
    158                  (+ count 1))))))
    159       (proc s b1 (string-length s)))))
     154    (let ((limit (string-length s)))
     155      (if (pair? opt2)
     156        (let ((end (car opt2)))
     157          (let lp ((b2 b1) (count start))
     158            (cond
     159              ((= count end) (proc s b1 b2))
     160              ((> b2 limit) (error "index out of range" s end))
     161              (else
     162               (lp (+ b2 (utf8-start-byte->length (string-int-ref s b2)))
     163                   (+ count 1))))))
     164        (proc s b1 limit)))) )
    160165
    161166(define (with-two-substring-offsets proc s1 s2 opt)
    162167  (with-substring-offsets
    163       (lambda (s1 start1 end1)
    164         (with-substring-offsets
    165             (lambda (s2 start2 end2)
    166               (proc s1 s2 start1 end1 start2 end2))
    167             s2 (if (and (pair? opt) (pair? (cdr opt))) (cddr opt) '())))
    168       s1 opt))
     168    (lambda (s1 start1 end1)
     169      (with-substring-offsets
     170        (lambda (s2 start2 end2)
     171          (proc s1 s2 start1 end1 start2 end2))
     172        s2 (if (and (pair? opt) (pair? (cdr opt))) (cddr opt) '())))
     173    s1 opt) )
    169174
    170175(define (utf8-string->list str)
  • release/3/utf8/tags/2.0.5/utf8-srfi-14.scm

    r9961 r12613  
    2020(register-feature! 'srfi-14)
    2121
    22 (declare (fixnum)) ; no chars above 2^21
    23 
    2422(declare
     23 (fixnum) ; no chars above 2^21
     24 (no-bound-checks)
     25 (no-procedure-checks)
    2526 (export
    2627  ;; srfi-14
  • release/3/utf8/tags/2.0.5/utf8-support.scm

    r9872 r12613  
    209209
    210210(declare
     211  (not usual-integrations
     212    ; Stop the rewriting by the compiler to ASCII-only routines in the 'sys namespace
     213    substring=? substring-ci=?         ;Just in case they are used later internally
     214    substring-index substring-index-ci ;-ditto-
     215    string-length
     216    substring
     217    string->list list->string
     218    read-char write-char )
    211219  (fixnum)  ; no chars above 2^21
    212220  (no-bound-checks)
     
    236244;; redefine char primitives
    237245
    238 #;
    239 (define (make-small-char-predicate pred)
    240   (lambda (c) (and (< (char->integer c) 128) (pred c))))
    241246(define-macro (make-small-char-predicate PRED)
    242247  `(lambda (c) (and (< (char->integer c) 128) (,PRED c))) )
     
    419424  (list->vector (string->list str)))
    420425
    421 (define (vector-memv x vec)
    422   (let ((len (vector-length vec)))
    423     (let loop ((i 0))
    424       (cond ((= i len) #f)
    425             ((eqv? x (vector-ref vec i)) i)
    426             (else (loop (+ i 1)))))))
    427 
    428426(define (string-translate str from . opt)
     427
     428  ;Until needed elsewhere
     429  (define (vector-char-scan vec ch . opts)
     430    (let-optionals opts ((st 0) (ed (vector-length vec)))
     431      (let loop ((i st))
     432        (cond ((= i ed)                         #f)
     433              ((char=? ch (vector-ref vec i))   i)
     434              (else
     435               (loop (+ i 1)) ) ) ) ) )
     436
    429437  (if (and (ascii-string? from)
    430            (or (null? opt) (ascii-string? (car opt))))
     438           (or (null? opt)
     439               (ascii-string? (car opt))))
    431440      (apply byte-string-translate str from opt)
    432       (let* ((from-vec (string->vector from)))
    433         (let ((to-vec (and (pair? opt) (string->vector (car opt)))))
     441      (let ((from-vec (string->vector from))
     442            (to-vec (and (pair? opt) (string->vector (car opt)))))
     443        (let ((trans (if to-vec
     444                         (lambda (i) (display (vector-ref to-vec i)))
     445                         noop)))
    434446          (with-output-to-string
    435447            (lambda ()
     
    438450                  (when (< i end)
    439451                    (let ((c (sp-ref str i)))
    440                       (display
    441                        (cond ((vector-memv c from-vec)
    442                               => (lambda (i) (vector-ref to-vec i)))
    443                              (else c)))
     452                      (cond ((vector-char-scan from-vec c) => trans)
     453                            (else (display c)))
    444454                      (lp (sp-next str i))))))))))))
     455
     456;Per Unit data-structures
     457#;
     458(define (string-translate str from . opt)
     459
     460  ;Until needed elsewhere
     461  (define (vector-char-scan vec ch . opts)
     462    (let-optionals opts ((st 0) (ed (vector-length vec)))
     463      (let loop ((i st))
     464        (cond ((= i ed)                         #f)
     465              ((char=? ch (vector-ref vec i))   i)
     466              (else
     467               (loop (+ i 1)) ) ) ) ) )
     468
     469        (##sys#check-string str 'string-translate)
     470  (let ((from (cond ((char? from)   from)
     471                    ((pair? from)   (list->string from))
     472                    (else
     473                     (##sys#check-string from 'string-translate)
     474                     from)))
     475        (to (and (pair? opt)
     476                 (let ((to (car opt)))
     477                   (cond ((char? to)   to)
     478                         ((pair? to)   (list->string to))
     479                         (else
     480                          (##sys#check-string to 'string-translate)
     481                          to))))) )
     482    (if (and (or (ascii-string? from)
     483                 (and (char? from) (> 128 (char->integer from))))
     484             to
     485             (or (ascii-string? to)
     486                 (and (char? to) (> 128 (char->integer to)))))
     487        (apply byte-string-translate str from opt)
     488        (let ((from-vec (if (char? from) (vector from) (string->vector from)))
     489              (to-vec (and to
     490                           (if (char? to) (vector to) (string->vector to)))) )
     491          (let ((trans (if to-vec
     492                           (lambda (i) (display (vector-ref to-vec i)))
     493                           noop)))
     494            (with-output-to-string
     495              (lambda ()
     496                (let ((end (sp-last str)))
     497                  (let lp ((i (sp-first str)))
     498                    (when (< i end)
     499                      (let ((c (sp-ref str i)))
     500                        (cond ((vector-char-scan from-vec c) => trans)
     501                              (else (display c)))
     502                        (lp (sp-next str i) ) ) ) ) ) ) ) ) ) ) ) )
    445503
    446504(define (substring=? s1 s2 . opt)
  • release/3/utf8/tags/2.0.5/utf8.setup

    r9872 r12613  
    66(install-extension 'byte-string
    77 '("byte-string.so")
    8  `((version "2.0.3")
     8 `((version "2.0.5")
    99   ,@(if has-exports? `((exports "byte-string.exports")) '()) ) )
    1010
    11 (compile -s -O2 -d1
     11(compile -s -optimize-level 3 -d1
    1212  ,@(if has-exports? '(-check-imports -emit-exports utf8-lolevel.exports) '())
    1313  utf8-lolevel.scm)
    1414(install-extension 'utf8-lolevel
    1515 '("utf8-lolevel.so")
    16  `((version "2.0.3")
     16 `((version "2.0.5")
    1717   ,@(if has-exports? `((exports "utf8-lolevel.exports")) '()) ) )
    1818
     
    2424   "utf8-support.so"
    2525   "utf8.html")
    26  `((version "2.0.3")
     26 `((version "2.0.5")
    2727   ,@(if has-exports? `((exports "utf8.exports")) '())
    2828   (syntax)
     
    3636 '("utf8-srfi-14.scm"
    3737   "utf8-srfi-14.so")
    38  `((version "2.0.3")
     38 `((version "2.0.5")
    3939   ,@(if has-exports? `((exports "utf8-srfi-14.exports")) '())
    4040   (documentation "utf8.html") ) )
     
    4545(install-extension 'byte-string-srfi-13
    4646 '("byte-string-srfi-13.so")
    47  `((version "2.0.3")
     47 `((version "2.0.5")
    4848   ,@(if has-exports? `((exports "byte-string-srfi-13.exports")) '())
    4949   (documentation "utf8.html") ) )
     
    5555 '("utf8-srfi-13.scm"
    5656   "utf8-srfi-13.so")
    57  `((version "2.0.3")
     57 `((version "2.0.5")
    5858   ,@(if has-exports? `((exports "utf8-srfi-13.exports")) '())
    5959   (documentation "utf8.html") ) )
     
    6464(install-extension 'unicode-char-sets
    6565 '("unicode-char-sets.so")
    66  `((version "2.0.3")
     66 `((version "2.0.5")
    6767   ,@(if has-exports? `((exports "unicode-char-sets.exports")) '())
    6868   (documentation "utf8.html") ) )
     
    7373(install-extension 'utf8-case-map
    7474 '("utf8-case-map.so" "case-map-1.dat" "case-map-2.dat")
    75  `((version "2.0.3")
     75 `((version "2.0.5")
    7676   ,@(if has-exports? `((exports "utf8-case-map.exports")) '())
    7777   (documentation "utf8.html") ) )
  • release/3/utf8/trunk/byte-string-srfi-13.scm

    r9961 r12613  
    1818
    1919(declare
    20   (usual-integrations)
    2120  (export
    2221    byte-string-upcase!
  • release/3/utf8/trunk/byte-string.scm

    r11873 r12613  
    44;; BSD-style license: http://synthcode.com/license.txt
    55
    6 (require-extension regex)
     6(require-extension data-structures extras regex)
    77
    88; (defun export-all ()
     
    1818
    1919(declare
    20   (usual-integrations)
    2120  (export
    2221    small-char-alphabetic?
  • release/3/utf8/trunk/tests/run.scm

    r9873 r12613  
    88(define *fail* 0)
    99
     10#;
    1011(define-macro (test form . opt)
    1112  (if (pair? opt)
     
    2324      `(begin (write ',form) (display " => ") (write ,form) (newline))))
    2425
     26(define (exn-condition->list cnd)
     27  (list
     28    ((condition-property-accessor 'exn 'location #f) cnd)
     29    ((condition-property-accessor 'exn 'message #f) cnd)
     30    ((condition-property-accessor 'exn 'arguments #f) cnd)) )
     31
     32(define-macro (test form . opt)
     33  (let ((res (gensym)) (expect (gensym)))
     34    `(let ((,res (condition-case ,form
     35                   (exn () (list 'error ',(gensym) "exception" (exn-condition->list exn)))))
     36           (,expect ,(optional opt #t)))
     37       (if (equal? ,res ,expect)
     38           (begin
     39             (set! *pass* (+ 1 *pass*))
     40             (display "[ OK ] ") (write ',form) (display " => ") (write ,res) (newline))
     41           (begin
     42             (set! *fail* (+ 1 *fail*))
     43             (display "[FAIL] ") (write ',form) (display " => ") (write ,res)
     44             (display " [expected ") (write ,expect) (display "]") (newline))))))
     45
    2546;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    2647;; R5RS
     
    241262
    242263(test (integer? (string-hash "abc")))
    243 (test (integer? (string-hash-ci "abc")))
     264(test (integer? (string-ci-hash "abc")))
    244265
    245266(test (not (= (string-hash "abc") (string-hash "abd"))))
    246 (test (= (string-hash-ci "abc") (string-hash-ci "aBc") (string-hash-ci "ABC")))
     267(test (= (string-ci-hash "abc") (string-ci-hash "aBc") (string-ci-hash "ABC")))
    247268
    248269(test (= (string-hash "いうえ" #xFFFF)
  • release/3/utf8/trunk/unicode-char-sets.scm

    r9872 r12613  
    66  ((and chicken compiling)
    77   (declare
     8     (fixnum) ; no chars above 2^21
     9     (usual-integrations)
     10     (no-bound-checks)
     11     (no-procedure-checks)
    812     (export
    913       char-set:alphabetic
  • release/3/utf8/trunk/utf8-case-map.scm

    r9872 r12613  
    1212;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1313
    14 (declare (fixnum)) ; no chars above 2^21
     14(declare
     15  (fixnum) ; no chars above 2^21
     16  (usual-integrations)
     17  (no-bound-checks)
     18  (no-procedure-checks) )
    1519
    1620(define-extension utf8-case-map
  • release/3/utf8/trunk/utf8-lolevel.scm

    r9872 r12613  
    1414;; 'sp-' is a string-pointer function referring to offsets.
    1515
     16;; Uses ##sys#become! since all types are correct at runtime.
     17;;
     18;; Assumes string-length, string-ref & string-set! are rewritten by the compiler.
     19
    1620(require-extension byte-string)
    1721
     
    1923  (fixnum) ; no chars above 2^21
    2024  (usual-integrations)
     25  (no-bound-checks)
     26  (no-procedure-checks)
    2127  (export
    2228    ;; utils
     
    5056  (let ((limit (string-length str)))
    5157    (let loop ((i 0))
    52       (if (= i limit)
    53         #t
    54         (and (> 128 (string-int-ref str i))
    55              (loop (+ i 1)))))))
     58      (or (= i limit)
     59          (and (> 128 (string-int-ref str i))
     60               (loop (+ i 1)))))))
    5661
    5762;; from SRFI-33, useful in splitting up the bit patterns used to
     
    147152         (b1 (utf8-index->offset s start))
    148153         (opt2 (if (pair? opt) (cdr opt) '())))
    149     (if (pair? opt2)
    150       (let ((limit (string-length s))
    151             (end (car opt2)))
    152         (let lp ((b2 b1) (count start))
    153           (cond
    154             ((= count end) (proc s b1 b2))
    155             ((> b2 limit) (error "index out of range" s end))
    156             (else
    157              (lp (+ b2 (utf8-start-byte->length (string-int-ref s b2)))
    158                  (+ count 1))))))
    159       (proc s b1 (string-length s)))))
     154    (let ((limit (string-length s)))
     155      (if (pair? opt2)
     156        (let ((end (car opt2)))
     157          (let lp ((b2 b1) (count start))
     158            (cond
     159              ((= count end) (proc s b1 b2))
     160              ((> b2 limit) (error "index out of range" s end))
     161              (else
     162               (lp (+ b2 (utf8-start-byte->length (string-int-ref s b2)))
     163                   (+ count 1))))))
     164        (proc s b1 limit)))) )
    160165
    161166(define (with-two-substring-offsets proc s1 s2 opt)
    162167  (with-substring-offsets
    163       (lambda (s1 start1 end1)
    164         (with-substring-offsets
    165             (lambda (s2 start2 end2)
    166               (proc s1 s2 start1 end1 start2 end2))
    167             s2 (if (and (pair? opt) (pair? (cdr opt))) (cddr opt) '())))
    168       s1 opt))
     168    (lambda (s1 start1 end1)
     169      (with-substring-offsets
     170        (lambda (s2 start2 end2)
     171          (proc s1 s2 start1 end1 start2 end2))
     172        s2 (if (and (pair? opt) (pair? (cdr opt))) (cddr opt) '())))
     173    s1 opt) )
    169174
    170175(define (utf8-string->list str)
  • release/3/utf8/trunk/utf8-srfi-14.scm

    r9961 r12613  
    2020(register-feature! 'srfi-14)
    2121
    22 (declare (fixnum)) ; no chars above 2^21
    23 
    2422(declare
     23 (fixnum) ; no chars above 2^21
     24 (no-bound-checks)
     25 (no-procedure-checks)
    2526 (export
    2627  ;; srfi-14
  • release/3/utf8/trunk/utf8-support.scm

    r9872 r12613  
    209209
    210210(declare
     211  (not usual-integrations
     212    ; Stop the rewriting by the compiler to ASCII-only routines in the 'sys namespace
     213    substring=? substring-ci=?         ;Just in case they are used later internally
     214    substring-index substring-index-ci ;-ditto-
     215    string-length
     216    substring
     217    string->list list->string
     218    read-char write-char )
    211219  (fixnum)  ; no chars above 2^21
    212220  (no-bound-checks)
     
    236244;; redefine char primitives
    237245
    238 #;
    239 (define (make-small-char-predicate pred)
    240   (lambda (c) (and (< (char->integer c) 128) (pred c))))
    241246(define-macro (make-small-char-predicate PRED)
    242247  `(lambda (c) (and (< (char->integer c) 128) (,PRED c))) )
     
    419424  (list->vector (string->list str)))
    420425
    421 (define (vector-memv x vec)
    422   (let ((len (vector-length vec)))
    423     (let loop ((i 0))
    424       (cond ((= i len) #f)
    425             ((eqv? x (vector-ref vec i)) i)
    426             (else (loop (+ i 1)))))))
    427 
    428426(define (string-translate str from . opt)
     427
     428  ;Until needed elsewhere
     429  (define (vector-char-scan vec ch . opts)
     430    (let-optionals opts ((st 0) (ed (vector-length vec)))
     431      (let loop ((i st))
     432        (cond ((= i ed)                         #f)
     433              ((char=? ch (vector-ref vec i))   i)
     434              (else
     435               (loop (+ i 1)) ) ) ) ) )
     436
    429437  (if (and (ascii-string? from)
    430            (or (null? opt) (ascii-string? (car opt))))
     438           (or (null? opt)
     439               (ascii-string? (car opt))))
    431440      (apply byte-string-translate str from opt)
    432       (let* ((from-vec (string->vector from)))
    433         (let ((to-vec (and (pair? opt) (string->vector (car opt)))))
     441      (let ((from-vec (string->vector from))
     442            (to-vec (and (pair? opt) (string->vector (car opt)))))
     443        (let ((trans (if to-vec
     444                         (lambda (i) (display (vector-ref to-vec i)))
     445                         noop)))
    434446          (with-output-to-string
    435447            (lambda ()
     
    438450                  (when (< i end)
    439451                    (let ((c (sp-ref str i)))
    440                       (display
    441                        (cond ((vector-memv c from-vec)
    442                               => (lambda (i) (vector-ref to-vec i)))
    443                              (else c)))
     452                      (cond ((vector-char-scan from-vec c) => trans)
     453                            (else (display c)))
    444454                      (lp (sp-next str i))))))))))))
     455
     456;Per Unit data-structures
     457#;
     458(define (string-translate str from . opt)
     459
     460  ;Until needed elsewhere
     461  (define (vector-char-scan vec ch . opts)
     462    (let-optionals opts ((st 0) (ed (vector-length vec)))
     463      (let loop ((i st))
     464        (cond ((= i ed)                         #f)
     465              ((char=? ch (vector-ref vec i))   i)
     466              (else
     467               (loop (+ i 1)) ) ) ) ) )
     468
     469        (##sys#check-string str 'string-translate)
     470  (let ((from (cond ((char? from)   from)
     471                    ((pair? from)   (list->string from))
     472                    (else
     473                     (##sys#check-string from 'string-translate)
     474                     from)))
     475        (to (and (pair? opt)
     476                 (let ((to (car opt)))
     477                   (cond ((char? to)   to)
     478                         ((pair? to)   (list->string to))
     479                         (else
     480                          (##sys#check-string to 'string-translate)
     481                          to))))) )
     482    (if (and (or (ascii-string? from)
     483                 (and (char? from) (> 128 (char->integer from))))
     484             to
     485             (or (ascii-string? to)
     486                 (and (char? to) (> 128 (char->integer to)))))
     487        (apply byte-string-translate str from opt)
     488        (let ((from-vec (if (char? from) (vector from) (string->vector from)))
     489              (to-vec (and to
     490                           (if (char? to) (vector to) (string->vector to)))) )
     491          (let ((trans (if to-vec
     492                           (lambda (i) (display (vector-ref to-vec i)))
     493                           noop)))
     494            (with-output-to-string
     495              (lambda ()
     496                (let ((end (sp-last str)))
     497                  (let lp ((i (sp-first str)))
     498                    (when (< i end)
     499                      (let ((c (sp-ref str i)))
     500                        (cond ((vector-char-scan from-vec c) => trans)
     501                              (else (display c)))
     502                        (lp (sp-next str i) ) ) ) ) ) ) ) ) ) ) ) )
    445503
    446504(define (substring=? s1 s2 . opt)
  • release/3/utf8/trunk/utf8.setup

    r9872 r12613  
    66(install-extension 'byte-string
    77 '("byte-string.so")
    8  `((version "2.0.3")
     8 `((version "2.0.5")
    99   ,@(if has-exports? `((exports "byte-string.exports")) '()) ) )
    1010
    11 (compile -s -O2 -d1
     11(compile -s -optimize-level 3 -d1
    1212  ,@(if has-exports? '(-check-imports -emit-exports utf8-lolevel.exports) '())
    1313  utf8-lolevel.scm)
    1414(install-extension 'utf8-lolevel
    1515 '("utf8-lolevel.so")
    16  `((version "2.0.3")
     16 `((version "2.0.5")
    1717   ,@(if has-exports? `((exports "utf8-lolevel.exports")) '()) ) )
    1818
     
    2424   "utf8-support.so"
    2525   "utf8.html")
    26  `((version "2.0.3")
     26 `((version "2.0.5")
    2727   ,@(if has-exports? `((exports "utf8.exports")) '())
    2828   (syntax)
     
    3636 '("utf8-srfi-14.scm"
    3737   "utf8-srfi-14.so")
    38  `((version "2.0.3")
     38 `((version "2.0.5")
    3939   ,@(if has-exports? `((exports "utf8-srfi-14.exports")) '())
    4040   (documentation "utf8.html") ) )
     
    4545(install-extension 'byte-string-srfi-13
    4646 '("byte-string-srfi-13.so")
    47  `((version "2.0.3")
     47 `((version "2.0.5")
    4848   ,@(if has-exports? `((exports "byte-string-srfi-13.exports")) '())
    4949   (documentation "utf8.html") ) )
     
    5555 '("utf8-srfi-13.scm"
    5656   "utf8-srfi-13.so")
    57  `((version "2.0.3")
     57 `((version "2.0.5")
    5858   ,@(if has-exports? `((exports "utf8-srfi-13.exports")) '())
    5959   (documentation "utf8.html") ) )
     
    6464(install-extension 'unicode-char-sets
    6565 '("unicode-char-sets.so")
    66  `((version "2.0.3")
     66 `((version "2.0.5")
    6767   ,@(if has-exports? `((exports "unicode-char-sets.exports")) '())
    6868   (documentation "utf8.html") ) )
     
    7373(install-extension 'utf8-case-map
    7474 '("utf8-case-map.so" "case-map-1.dat" "case-map-2.dat")
    75  `((version "2.0.3")
     75 `((version "2.0.5")
    7676   ,@(if has-exports? `((exports "utf8-case-map.exports")) '())
    7777   (documentation "utf8.html") ) )
Note: See TracChangeset for help on using the changeset viewer.