home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / string.scm < prev    next >
Text File  |  2001-06-15  |  41KB  |  1,121 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: string.scm,v 14.43 2001/06/15 20:38:46 cph Exp $
  4.  
  5. Copyright (c) 1988-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  20. 02111-1307, USA.
  21. |#
  22.  
  23. ;;;; Character String Operations
  24. ;;; package: (runtime string)
  25.  
  26. ;; NOTE
  27. ;;
  28. ;; This file is designed to be compiled with type and range checking
  29. ;; turned off. The advertised user-visible procedures all explicitly
  30. ;; check their arguments.
  31. ;;
  32. ;; Many of the procedures are split into several user versions that just
  33. ;; validate their arguments and pass them on to an internal version
  34. ;; (prefixed with `%') that assumes all arguments have been checked.
  35. ;; This avoids repeated argument checks.
  36.  
  37. (declare (usual-integrations)
  38.      (integrate-external "chrset"))
  39.  
  40. ;;;; Primitives
  41.  
  42. (define-primitives
  43.   string-allocate string? string-ref string-set!
  44.   string-length set-string-length!
  45.   string-maximum-length set-string-maximum-length!
  46.   substring=? substring-ci=? substring<?
  47.   substring-move-right! substring-move-left!
  48.   substring-match-forward substring-match-backward
  49.   substring-match-forward-ci substring-match-backward-ci
  50.   substring-upcase! substring-downcase! string-hash string-hash-mod
  51.  
  52.   vector-8b-ref vector-8b-set! vector-8b-fill!
  53.   vector-8b-find-next-char vector-8b-find-previous-char
  54.   vector-8b-find-next-char-ci vector-8b-find-previous-char-ci)
  55.  
  56. ;;; Character Covers
  57.  
  58. (define-integrable (substring-fill! string start end char)
  59.   (vector-8b-fill! string start end (char->ascii char)))
  60.  
  61. (define-integrable (substring-find-next-char string start end char)
  62.   (vector-8b-find-next-char string start end (char->ascii char)))
  63.  
  64. (define-integrable (substring-find-previous-char string start end char)
  65.   (vector-8b-find-previous-char string start end (char->ascii char)))
  66.  
  67. (define-integrable (substring-find-next-char-ci string start end char)
  68.   (vector-8b-find-next-char-ci string start end (char->ascii char)))
  69.  
  70. (define-integrable (substring-find-previous-char-ci string start end char)
  71.   (vector-8b-find-previous-char-ci string start end (char->ascii char)))
  72.  
  73. ;;; Special, not implemented in microcode.
  74.  
  75. (define (substring-ci<? string1 start1 end1 string2 start2 end2)
  76.   (let ((match (substring-match-forward-ci string1 start1 end1
  77.                        string2 start2 end2))
  78.     (len1 (fix:- end1 start1))
  79.     (len2 (fix:- end2 start2)))
  80.     (and (not (fix:= match len2))
  81.      (or (fix:= match len1)
  82.          (char-ci<? (string-ref string1 (fix:+ match start1))
  83.             (string-ref string2 (fix:+ match start2)))))))
  84.  
  85. ;;; Substring Covers
  86.  
  87. (define (string=? string1 string2)
  88.   (guarantee-2-strings string1 string2 'STRING=?)
  89.   (substring=? string1 0 (string-length string1)
  90.            string2 0 (string-length string2)))
  91.  
  92. (define (string-ci=? string1 string2)
  93.   (guarantee-2-strings string1 string2 'STRING-CI=?)
  94.   (substring-ci=? string1 0 (string-length string1)
  95.           string2 0 (string-length string2)))
  96.  
  97. (define (string<? string1 string2)
  98.   (guarantee-2-strings string1 string2 'STRING<?)
  99.   (substring<? string1 0 (string-length string1)
  100.            string2 0 (string-length string2)))
  101.  
  102. (define (string-ci<? string1 string2)
  103.   (guarantee-2-strings string1 string2 'STRING-ci<?)
  104.   (substring-ci<? string1 0 (string-length string1)
  105.           string2 0 (string-length string2)))
  106.  
  107. (define (string>? string1 string2)
  108.   (guarantee-2-strings string1 string2 'STRING>?)
  109.   (substring<? string2 0 (string-length string2)
  110.            string1 0 (string-length string1)))
  111.  
  112. (define (string-ci>? string1 string2)
  113.   (guarantee-2-strings string1 string2 'STRING-CI>?)
  114.   (substring-ci<? string2 0 (string-length string2)
  115.           string1 0 (string-length string1)))
  116.  
  117. (define (string>=? string1 string2)
  118.   (guarantee-2-strings string1 string2 'STRING-CI>=?)
  119.   (not (substring<? string1 0 (string-length string1)
  120.             string2 0 (string-length string2))))
  121.  
  122. (define (string-ci>=? string1 string2)
  123.   (guarantee-2-strings string1 string2 'STRING-CI>=?)
  124.   (not (substring-ci<? string1 0 (string-length string1)
  125.                string2 0 (string-length string2))))
  126.  
  127. (define (string<=? string1 string2)
  128.   (guarantee-2-strings string1 string2 'STRING<=?)
  129.   (not (substring<? string2 0 (string-length string2)
  130.             string1 0 (string-length string1))))
  131.  
  132. (define (string-ci<=? string1 string2)
  133.   (guarantee-2-strings string1 string2 'STRING-ci<=?)
  134.   (not (substring-ci<? string2 0 (string-length string2)
  135.                string1 0 (string-length string1))))
  136.  
  137. (define (string-fill! string char)
  138.   (guarantee-string string 'STRING-FILL!)
  139.   (substring-fill! string 0 (string-length string) char))
  140.  
  141. (define (string-find-next-char string char)
  142.   (guarantee-string string 'STRING-FIND-NEXT-CHAR)
  143.   (substring-find-next-char string 0 (string-length string) char))
  144.  
  145. (define (string-find-previous-char string char)
  146.   (guarantee-string string 'STRING-FIND-PREVIOUS-CHAR)
  147.   (substring-find-previous-char string 0 (string-length string) char))
  148.  
  149. (define (string-find-next-char-ci string char)
  150.   (guarantee-string string 'STRING-FIND-NEXT-CHAR-CI)
  151.   (substring-find-next-char-ci string 0 (string-length string) char))
  152.  
  153. (define (string-find-previous-char-ci string char)
  154.   (guarantee-string string 'STRING-FIND-PREVIOUS-CHAR-CI)
  155.   (substring-find-previous-char-ci string 0 (string-length string) char))
  156.  
  157. (define (string-find-next-char-in-set string char-set)
  158.   (guarantee-string string 'STRING-FIND-NEXT-CHAR-IN-SET)
  159.   (guarantee-char-set char-set 'STRING-FIND-NEXT-CHAR-IN-SET)
  160.   ((ucode-primitive substring-find-next-char-in-set)
  161.    string 0 (string-length string)
  162.    (char-set-table char-set)))
  163.  
  164. (define (string-find-previous-char-in-set string char-set)
  165.   (guarantee-string string 'STRING-FIND-PREVIOUS-CHAR-IN-SET)
  166.   (guarantee-char-set char-set 'STRING-FIND-PREVIOUS-CHAR-IN-SET)
  167.   ((ucode-primitive substring-find-previous-char-in-set)
  168.    string 0 (string-length string)
  169.    (char-set-table char-set)))
  170.  
  171. (define (substring-find-next-char-in-set string start end char-set)
  172.   (guarantee-substring string start end 'SUBSTRING-FIND-NEXT-CHAR-IN-SET)
  173.   (guarantee-char-set char-set 'SUBSTRING-FIND-NEXT-CHAR-IN-SET)
  174.   ((ucode-primitive substring-find-next-char-in-set)
  175.    string start end
  176.    (char-set-table char-set)))
  177.  
  178. (define (substring-find-previous-char-in-set string start end char-set)
  179.   (guarantee-substring string start end 'SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET)
  180.   (guarantee-char-set char-set 'SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET)
  181.   ((ucode-primitive substring-find-previous-char-in-set)
  182.    string start end
  183.    (char-set-table char-set)))
  184.  
  185. (define (string-match-forward string1 string2)
  186.   (guarantee-2-strings string1 string2 'STRING-MATCH-FORWARD)
  187.   (substring-match-forward string1 0 (string-length string1)
  188.                string2 0 (string-length string2)))
  189.  
  190. (define (string-match-backward string1 string2)
  191.   (guarantee-2-strings string1 string2 'STRING-MATCH-BACKWARD)
  192.   (substring-match-backward string1 0 (string-length string1)
  193.                 string2 0 (string-length string2)))
  194.  
  195. (define (string-match-forward-ci string1 string2)
  196.   (guarantee-2-strings string1 string2 'STRING-MATCH-FORWARD-CI)
  197.   (substring-match-forward-ci string1 0 (string-length string1)
  198.                   string2 0 (string-length string2)))
  199.  
  200. (define (string-match-backward-ci string1 string2)
  201.   (guarantee-2-strings string1 string2 'STRING-MATCH-BACKWARD-CI)
  202.   (substring-match-backward-ci string1 0 (string-length string1)
  203.                    string2 0 (string-length string2)))
  204.  
  205. ;;;; Basic Operations
  206.  
  207. (define (make-string length #!optional char)
  208.   (guarantee-index/string length 'MAKE-STRING)
  209.   (if (default-object? char)
  210.       (string-allocate length)
  211.       (let ((result (string-allocate length)))
  212.     (substring-fill! result 0 length char)
  213.     result)))
  214.  
  215. (define (string-null? string)
  216.   (guarantee-string string 'STRING-NULL?)
  217.   (%string-null? string))
  218.  
  219. (define-integrable (%string-null? string)
  220.   (fix:= 0 (string-length string)))
  221.  
  222. (declare (integrate-operator %substring))
  223. (define (%substring string start end)
  224.   (let ((result (string-allocate (fix:- end start))))
  225.     (%substring-move! string start end result 0)
  226.     result))
  227.  
  228. (define (substring string start end)
  229.   (guarantee-substring string start end 'SUBSTRING)
  230.   (%substring string start end))
  231.  
  232. (define (string-head string end)
  233.   (guarantee-string string 'STRING-HEAD)
  234.   (guarantee-index/string end 'STRING-HEAD)
  235.   (%substring string 0 end))
  236.  
  237. (define (string-tail string start)
  238.   (guarantee-string string 'STRING-TAIL)
  239.   (guarantee-index/string start 'STRING-TAIL)
  240.   (%substring string start (string-length string)))
  241.  
  242. (define (list->string chars)
  243.   ;; This should check that each element of CHARS satisfies CHAR? but at
  244.   ;; worst it will generate strings containing rubbish from the
  245.   ;; addresses of the objects ...
  246.   (let ((result (string-allocate (length chars))))
  247.     (let loop ((index 0) (chars chars))
  248.       (if (pair? chars)
  249.       ;; LENGTH would have barfed if input is not a proper list:
  250.       (begin
  251.         (string-set! result index (car chars))
  252.         (loop (fix:+ index 1) (cdr chars)))
  253.       result))))
  254.  
  255. (define (string . chars)
  256.   (list->string chars))
  257.  
  258. (define char->string string)
  259.  
  260. (define (string->list string)
  261.   (guarantee-string string 'STRING->LIST)
  262.   (%substring->list string 0 (string-length string)))
  263.  
  264. (define (%substring->list string start end)
  265.   (let loop ((index (fix:- end 1)) (list '()))
  266.     (if (fix:>= index start)
  267.     (loop (fix:- index 1)
  268.           (cons (string-ref string index) list))
  269.     list)))
  270.  
  271. (define (substring->list string start end)
  272.   (guarantee-substring string start end 'SUBSTRING->LIST)
  273.   (%substring->list string start end))
  274.  
  275. (define (string-copy string)
  276.   (guarantee-string string 'STRING-COPY)
  277.   (let ((size (string-length string)))
  278.     (let ((result (string-allocate size)))
  279.       (%substring-move! string 0 size result 0)
  280.       result)))
  281.  
  282. (define (string-move! string1 string2 start2)
  283.   (guarantee-string string1 'STRING-MOVE!)
  284.   (guarantee-string string2 'STRING-MOVE!)
  285.   (guarantee-index/string start2 'STRING-MOVE!)
  286.   (let ((end1 (string-length string1)))
  287.     (if (not (fix:<= (fix:+ start2 end1) (string-length string2)))
  288.     (error:bad-range-argument start2 'STRING-MOVE!))
  289.     (%substring-move! string1 0 end1 string2 start2)))
  290.  
  291. (define (substring-move! string1 start1 end1 string2 start2)
  292.   (guarantee-substring string1 start1 end1 'SUBSTRING-MOVE!)
  293.   (guarantee-string string2 'SUBSTRING-MOVE!)
  294.   (guarantee-index/string start2 'SUBSTRING-MOVE!)
  295.   (if (not (fix:<= (fix:+ start2 (fix:- end1 start1)) (string-length string2)))
  296.       (error:bad-range-argument start2 'SUBSTRING-MOVE!))
  297.   (%substring-move! string1 start1 end1 string2 start2))
  298.  
  299. (define (%substring-move! string1 start1 end1 string2 start2)
  300.   ;; Calling the primitive is expensive, so avoid it for small copies.
  301.   (let-syntax
  302.       ((unrolled-move-left
  303.     (lambda (n)
  304.       `(BEGIN
  305.          (STRING-SET! STRING2 START2 (STRING-REF STRING1 START1))
  306.          ,@(let loop ((i 1))
  307.          (if (< i n)
  308.              `((STRING-SET! STRING2 (FIX:+ START2 ,i)
  309.                     (STRING-REF STRING1 (FIX:+ START1 ,i)))
  310.                ,@(loop (+ i 1)))
  311.              '())))))
  312.        (unrolled-move-right
  313.     (lambda (n)
  314.       `(BEGIN
  315.          ,@(let loop ((i 1))
  316.          (if (< i n)
  317.              `(,@(loop (+ i 1))
  318.                (STRING-SET! STRING2 (FIX:+ START2 ,i)
  319.                     (STRING-REF STRING1 (FIX:+ START1 ,i))))
  320.              '()))
  321.          (STRING-SET! STRING2 START2 (STRING-REF STRING1 START1))))))
  322.     (let ((n (fix:- end1 start1)))
  323.       (if (or (not (eq? string2 string1)) (fix:< start2 start1))
  324.       (cond ((fix:> n 4)
  325.          (if (fix:> n 32)
  326.              (substring-move-left! string1 start1 end1 string2 start2)
  327.              (let loop ((i1 start1) (i2 start2))
  328.                (if (fix:< i1 end1)
  329.                (begin
  330.                  (string-set! string2 i2 (string-ref string1 i1))
  331.                  (loop (fix:+ i1 1) (fix:+ i2 1)))))))
  332.         ((fix:= n 4) (unrolled-move-left 4))
  333.         ((fix:= n 3) (unrolled-move-left 3))
  334.         ((fix:= n 2) (unrolled-move-left 2))
  335.         ((fix:= n 1) (unrolled-move-left 1)))
  336.       (cond ((fix:> n 4)
  337.          (if (fix:> n 32)
  338.              (substring-move-right! string1 start1 end1 string2 start2)
  339.              (let loop ((i1 end1) (i2 (fix:+ start2 n)))
  340.                (if (fix:> i1 start1)
  341.                (let ((i1 (fix:- i1 1))
  342.                  (i2 (fix:- i2 1)))
  343.                  (string-set! string2 i2 (string-ref string1 i1))
  344.                  (loop i1 i2))))))
  345.         ((fix:= n 4) (unrolled-move-right 4))
  346.         ((fix:= n 3) (unrolled-move-right 3))
  347.         ((fix:= n 2) (unrolled-move-right 2))
  348.         ((fix:= n 1) (unrolled-move-right 1))))
  349.       (fix:+ start2 n))))
  350.  
  351. (define (string-append . strings)
  352.   (%string-append strings))
  353.  
  354. (define (%string-append strings)
  355.   (let ((result
  356.      (string-allocate
  357.       (let loop ((strings strings) (length 0))
  358.         (if (pair? strings)
  359.         (begin
  360.           (guarantee-string (car strings) 'STRING-APPEND)
  361.           (loop (cdr strings)
  362.             (fix:+ (string-length (car strings)) length)))
  363.         length)))))
  364.     (let loop ((strings strings) (index 0))
  365.       (if (pair? strings)
  366.       (let ((size (string-length (car strings))))
  367.         (%substring-move! (car strings) 0 size result index)
  368.         (loop (cdr strings) (fix:+ index size)))
  369.       result))))
  370.  
  371. (define (decorated-string-append prefix infix suffix strings)
  372.   (guarantee-string prefix 'DECORATED-STRING-APPEND)
  373.   (guarantee-string infix 'DECORATED-STRING-APPEND)
  374.   (guarantee-string suffix 'DECORATED-STRING-APPEND)
  375.   (%decorated-string-append prefix infix suffix strings
  376.                 'DECORATED-STRING-APPEND))
  377.  
  378. (define (%decorated-string-append prefix infix suffix strings procedure)
  379.   (if (pair? strings)
  380.       (let ((np (string-length prefix))
  381.         (ni (string-length infix))
  382.         (ns (string-length suffix)))
  383.     (guarantee-string (car strings) procedure)
  384.     (let ((string
  385.            (make-string
  386.         (let ((ni* (fix:+ np (fix:+ ni ns))))
  387.           (do ((strings (cdr strings) (cdr strings))
  388.                (count (fix:+ np (string-length (car strings)))
  389.                   (fix:+ count
  390.                      (fix:+ ni*
  391.                         (string-length (car strings))))))
  392.               ((not (pair? strings))
  393.                (fix:+ count ns))
  394.             (guarantee-string (car strings) procedure))))))
  395.       (let ((mp
  396.          (lambda (index)
  397.            (%substring-move! prefix 0 np string index)))
  398.         (mi
  399.          (lambda (index)
  400.            (%substring-move! infix 0 ni string index)))
  401.         (ms
  402.          (lambda (index)
  403.            (%substring-move! suffix 0 ns string index)))
  404.         (mv
  405.          (lambda (s index)
  406.            (%substring-move! s 0 (string-length s) string index))))
  407.         (let loop
  408.         ((strings (cdr strings))
  409.          (index (mv (car strings) (mp 0))))
  410.           (if (pair? strings)
  411.           (loop (cdr strings)
  412.             (mv (car strings) (mp (mi (ms index)))))
  413.           (ms index))))
  414.       string))
  415.       (make-string 0)))
  416.  
  417. (define (burst-string string delimiter allow-runs?)
  418.   (guarantee-string string 'BURST-STRING)
  419.   (let ((end (string-length string)))
  420.     (cond ((char? delimiter)
  421.        (let loop ((start 0) (index 0) (result '()))
  422.          (cond ((fix:= index end)
  423.             (reverse!
  424.              (if (and allow-runs? (fix:= start index))
  425.              result
  426.              (cons (substring string start index) result))))
  427.            ((char=? delimiter (string-ref string index))
  428.             (loop (fix:+ index 1)
  429.               (fix:+ index 1)
  430.               (if (and allow-runs? (fix:= start index))
  431.                   result
  432.                   (cons (substring string start index) result))))
  433.            (else
  434.             (loop start (fix:+ index 1) result)))))
  435.       ((char-set? delimiter)
  436.        (let loop ((start 0) (index 0) (result '()))
  437.          (cond ((fix:= index end)
  438.             (reverse!
  439.              (if (and allow-runs? (fix:= start index))
  440.              result
  441.              (cons (substring string start index) result))))
  442.            ((char-set-member? delimiter (string-ref string index))
  443.             (loop (fix:+ index 1)
  444.               (fix:+ index 1)
  445.               (if (and allow-runs? (fix:= start index))
  446.                   result
  447.                   (cons (substring string start index) result))))
  448.            (else
  449.             (loop start (fix:+ index 1) result)))))
  450.       (else
  451.        (error:wrong-type-argument delimiter "character or character set"
  452.                       'BURST-STRING)))))
  453.  
  454. (define (reverse-string string)
  455.   (guarantee-string string 'REVERSE-STRING)
  456.   (%reverse-substring string 0 (string-length string)))
  457.  
  458. (define (reverse-substring string start end)
  459.   (guarantee-substring string start end 'REVERSE-SUBSTRING)
  460.   (%reverse-substring string start end))
  461.  
  462. (define (%reverse-substring string start end)
  463.   (let ((result (make-string (fix:- end start)))
  464.     (k (fix:- end 1)))
  465.     (do ((i start (fix:+ i 1)))
  466.     ((fix:= i end))
  467.       (string-set! result (fix:- k i) (string-ref string i)))
  468.     result))
  469.  
  470. (define (reverse-string! string)
  471.   (guarantee-string string 'REVERSE-STRING!)
  472.   (%reverse-substring! string 0 (string-length string)))
  473.  
  474. (define (reverse-substring! string start end)
  475.   (guarantee-substring string start end 'REVERSE-SUBSTRING!)
  476.   (%reverse-substring! string start end))
  477.  
  478. (define (%reverse-substring! string start end)
  479.   (let ((k (fix:+ start (fix:quotient (fix:- end start) 2))))
  480.     (do ((i start (fix:+ i 1))
  481.      (j (fix:- end 1) (fix:- j 1)))
  482.     ((fix:= i k))
  483.       (let ((char (string-ref string j)))
  484.     (string-set! string j (string-ref string i))
  485.     (string-set! string i char)))))
  486.  
  487. ;;;; Case
  488.  
  489. (define (string-upper-case? string)
  490.   (guarantee-string string 'STRING-UPPER-CASE?)
  491.   (%substring-upper-case? string 0 (string-length string)))
  492.  
  493. (define (substring-upper-case? string start end)
  494.   (guarantee-substring string start end 'SUBSTRING-UPPER-CASE?)
  495.   (%substring-upper-case? string start end))
  496.  
  497. (define (%substring-upper-case? string start end)
  498.   (let find-upper ((start start))
  499.     (and (fix:< start end)
  500.      (let ((char (string-ref string start)))
  501.        (if (char-upper-case? char)
  502.            (let search-rest ((start (fix:+ start 1)))
  503.          (or (fix:= start end)
  504.              (and (not (char-lower-case? (string-ref string start)))
  505.               (search-rest (fix:+ start 1)))))
  506.            (and (not (char-lower-case? char))
  507.             (find-upper (fix:+ start 1))))))))
  508.  
  509. (define (string-upcase string)
  510.   (let ((string (string-copy string)))
  511.     (substring-upcase! string 0 (string-length string))
  512.     string))
  513.  
  514. (define (string-upcase! string)
  515.   (guarantee-string string 'STRING-UPCASE!)
  516.   (substring-upcase! string 0 (string-length string)))
  517.  
  518. (define (string-lower-case? string)
  519.   (guarantee-string string 'STRING-LOWER-CASE?)
  520.   (%substring-lower-case? string 0 (string-length string)))
  521.  
  522. (define (substring-lower-case? string start end)
  523.   (guarantee-substring string start end 'SUBSTRING-LOWER-CASE?)
  524.   (%substring-lower-case? string start end))
  525.  
  526. (define (%substring-lower-case? string start end)
  527.   (let find-lower ((start start))
  528.     (and (fix:< start end)
  529.      (let ((char (string-ref string start)))
  530.        (if (char-lower-case? char)
  531.            (let search-rest ((start (fix:+ start 1)))
  532.          (or (fix:= start end)
  533.              (and (not (char-upper-case? (string-ref string start)))
  534.               (search-rest (fix:+ start 1)))))
  535.            (and (not (char-upper-case? char))
  536.             (find-lower (fix:+ start 1))))))))
  537.  
  538. (define (string-downcase string)
  539.   (let ((string (string-copy string)))
  540.     (substring-downcase! string 0 (string-length string))
  541.     string))
  542.  
  543. (define (string-downcase! string)
  544.   (guarantee-string string 'STRING-DOWNCASE!)
  545.   (substring-downcase! string 0 (string-length string)))
  546.  
  547. (define (string-capitalized? string)
  548.   (guarantee-string string 'STRING-CAPITALIZED?)
  549.   (substring-capitalized? string 0 (string-length string)))
  550.  
  551. (define (substring-capitalized? string start end)
  552.   (guarantee-substring string start end 'SUBSTRING-CAPITALIZED?)
  553.   (%substring-capitalized? string start end))
  554.  
  555. (define (%substring-capitalized? string start end)
  556.   ;; Testing for capitalization is somewhat more involved than testing
  557.   ;; for upper or lower case.  This algorithm requires that the first
  558.   ;; word be capitalized, and that the subsequent words be either
  559.   ;; lower case or capitalized.  This is a very general definition of
  560.   ;; capitalization; if you need something more specific you should
  561.   ;; call this procedure on the individual words.
  562.   (letrec
  563.       ((find-first-word
  564.     (lambda (start)
  565.       (and (fix:< start end)
  566.            (let ((char (string-ref string start)))
  567.          (if (char-upper-case? char)
  568.              (scan-word-tail (fix:+ start 1))
  569.              (and (not (char-lower-case? char))
  570.               (find-first-word (fix:+ start 1))))))))
  571.        (scan-word-tail
  572.     (lambda (start)
  573.       (or (fix:= start end)
  574.           (let ((char (string-ref string start)))
  575.         (if (char-lower-case? char)
  576.             (scan-word-tail (fix:+ start 1))
  577.             (and (not (char-upper-case? char))
  578.              (find-subsequent-word (fix:+ start 1))))))))
  579.        (find-subsequent-word
  580.     (lambda (start)
  581.       (or (fix:= start end)
  582.           (let ((char (string-ref string start)))
  583.         (if (char-alphabetic? char)
  584.             (scan-word-tail (fix:+ start 1))
  585.             (find-subsequent-word (fix:+ start 1))))))))
  586.     (find-first-word start)))
  587.  
  588. (define (string-capitalize string)
  589.   (let ((string (string-copy string)))
  590.     (substring-capitalize! string 0 (string-length string))
  591.     string))
  592.  
  593. (define (string-capitalize! string)
  594.   (guarantee-string string 'STRING-CAPITALIZE!)
  595.   (substring-capitalize! string 0 (string-length string)))
  596.  
  597. (define (substring-capitalize! string start end)
  598.   ;; This algorithm capitalizes the first word in the substring and
  599.   ;; downcases the subsequent words.  This is arbitrary, but seems
  600.   ;; useful if the substring happens to be a sentence.  Again, if you
  601.   ;; need finer control, parse the words yourself.
  602.   (let ((index
  603.      (substring-find-next-char-in-set string start end
  604.                       char-set:alphabetic)))
  605.     (if index
  606.     (begin
  607.       (substring-upcase! string index (fix:+ index 1))
  608.       (substring-downcase! string (fix:+ index 1) end)))))
  609.  
  610. ;;;; Replace
  611.  
  612. (define (string-replace string char1 char2)
  613.   (let ((string (string-copy string)))
  614.     (string-replace! string char1 char2)
  615.     string))
  616.  
  617. (define (substring-replace string start end char1 char2)
  618.   (let ((string (string-copy string)))
  619.     (substring-replace! string start end char1 char2)
  620.     string))
  621.  
  622. (define (string-replace! string char1 char2)
  623.   (guarantee-string string 'STRING-REPLACE!)
  624.   (substring-replace! string 0 (string-length string) char1 char2))
  625.  
  626. (define (substring-replace! string start end char1 char2)
  627.   (let loop ((start start))
  628.     (let ((index (substring-find-next-char string start end char1)))
  629.       (if index
  630.       (begin
  631.         (string-set! string index char2)
  632.         (loop (fix:+ index 1)))))))
  633.  
  634. ;;;; Compare
  635.  
  636. (define (string-compare string1 string2 if= if< if>)
  637.   (guarantee-2-strings string1 string2 'STRING-COMPARE)
  638.   (let ((size1 (string-length string1))
  639.     (size2 (string-length string2)))
  640.     (let ((match (substring-match-forward string1 0 size1 string2 0 size2)))
  641.       ((if (fix:= match size1)
  642.        (if (fix:= match size2) if= if<)
  643.        (if (fix:= match size2) if>
  644.            (if (char<? (string-ref string1 match)
  645.                (string-ref string2 match))
  646.            if< if>)))))))
  647.  
  648. (define (string-prefix? string1 string2)
  649.   (guarantee-2-strings string1 string2 'STRING-PREFIX?)
  650.   (%substring-prefix? string1 0 (string-length string1)
  651.               string2 0 (string-length string2)))
  652.  
  653. (define (substring-prefix? string1 start1 end1 string2 start2 end2)
  654.   (guarantee-2-substrings string1 start1 end1
  655.               string2 start2 end2
  656.               'SUBSTRING-PREFIX?)
  657.   (%substring-prefix? string1 start1 end1
  658.               string2 start2 end2))
  659.  
  660. (define (%substring-prefix? string1 start1 end1 string2 start2 end2)
  661.   (let ((length (fix:- end1 start1)))
  662.     (and (fix:<= length (fix:- end2 start2))
  663.      (fix:= (substring-match-forward string1 start1 end1
  664.                      string2 start2 end2)
  665.         length))))
  666.  
  667. (define (string-suffix? string1 string2)
  668.   (guarantee-2-strings string1 string2 'STRING-SUFFIX?)
  669.   (%substring-suffix? string1 0 (string-length string1)
  670.               string2 0 (string-length string2)))
  671.  
  672. (define (substring-suffix? string1 start1 end1 string2 start2 end2)
  673.   (guarantee-2-substrings string1 start1 end1
  674.               string2 start2 end2
  675.               'SUBSTRING-SUFFIX?)
  676.   (%substring-suffix? string1 start1 end1
  677.               string2 start2 end2))
  678.  
  679. (define (%substring-suffix? string1 start1 end1 string2 start2 end2)
  680.   (let ((length (fix:- end1 start1)))
  681.     (and (fix:<= length (fix:- end2 start2))
  682.      (fix:= (substring-match-backward string1 start1 end1
  683.                       string2 start2 end2)
  684.         length))))
  685.  
  686. (define (string-compare-ci string1 string2 if= if< if>)
  687.   (guarantee-2-strings string1 string2 'STRING-COMPARE-CI)
  688.   (let ((size1 (string-length string1))
  689.     (size2 (string-length string2)))
  690.     (let ((match (substring-match-forward-ci string1 0 size1 string2 0 size2)))
  691.       ((if (fix:= match size1)
  692.        (if (fix:= match size2) if= if<)
  693.        (if (fix:= match size2) if>
  694.            (if (char-ci<? (string-ref string1 match)
  695.                   (string-ref string2 match))
  696.            if< if>)))))))
  697.  
  698. (define (string-prefix-ci? string1 string2)
  699.   (guarantee-2-strings string1 string2 'STRING-PREFIX-CI?)
  700.   (%substring-prefix-ci? string1 0 (string-length string1)
  701.              string2 0 (string-length string2)))
  702.  
  703. (define (substring-prefix-ci? string1 start1 end1 string2 start2 end2)
  704.   (guarantee-2-substrings string1 start1 end1
  705.               string2 start2 end2
  706.               'SUBSTRING-PREFIX-CI?)
  707.   (%substring-prefix-ci? string1 start1 end1
  708.              string2 start2 end2))
  709.  
  710. (define (%substring-prefix-ci? string1 start1 end1 string2 start2 end2)
  711.   (let ((length (fix:- end1 start1)))
  712.     (and (fix:<= length (fix:- end2 start2))
  713.      (fix:= (substring-match-forward-ci string1 start1 end1
  714.                         string2 start2 end2)
  715.         length))))
  716.  
  717. (define (string-suffix-ci? string1 string2)
  718.   (guarantee-2-strings string1 string2 'STRING-SUFFIX-CI?)
  719.   (%substring-suffix-ci? string1 0 (string-length string1)
  720.              string2 0 (string-length string2)))
  721.  
  722. (define (substring-suffix-ci? string1 start1 end1 string2 start2 end2)
  723.   (guarantee-2-substrings string1 start1 end1
  724.               string2 start2 end2
  725.               'SUBSTRING-SUFFIX-CI?)
  726.   (%substring-suffix-ci? string1 start1 end1
  727.              string2 start2 end2))
  728.  
  729. (define (%substring-suffix-ci? string1 start1 end1 string2 start2 end2)
  730.   (let ((length (fix:- end1 start1)))
  731.     (and (fix:<= length (fix:- end2 start2))
  732.      (fix:= (substring-match-backward-ci string1 start1 end1
  733.                          string2 start2 end2)
  734.         length))))
  735.  
  736. ;;;; Trim/Pad
  737.  
  738. (define (string-trim-left string #!optional char-set)
  739.   (let ((index
  740.      (string-find-next-char-in-set string
  741.                        (if (default-object? char-set)
  742.                        char-set:not-whitespace
  743.                        char-set)))
  744.     (length (string-length string)))
  745.     (if index
  746.     (%substring string index length)
  747.     "")))
  748.  
  749. (define (string-trim-right string #!optional char-set)
  750.   (let ((index
  751.      (string-find-previous-char-in-set string
  752.                        (if (default-object? char-set)
  753.                            char-set:not-whitespace
  754.                            char-set))))
  755.     (if index
  756.     (%substring string 0 (fix:+ index 1))
  757.     "")))
  758.  
  759. (define (string-trim string #!optional char-set)
  760.   (let ((char-set
  761.      (if (default-object? char-set) char-set:not-whitespace char-set)))
  762.     (let ((index (string-find-next-char-in-set string char-set)))
  763.       (if index
  764.       (%substring string
  765.               index
  766.               (fix:+ (string-find-previous-char-in-set string char-set)
  767.                  1))
  768.       ""))))
  769.  
  770. (define (string-pad-right string n #!optional char)
  771.   (guarantee-string string 'STRING-PAD-RIGHT)
  772.   (guarantee-index/string n 'STRING-PAD-RIGHT)
  773.   (let ((length (string-length string)))
  774.     (if (fix:= length n)
  775.     string
  776.     (let ((result (string-allocate n)))
  777.       (if (fix:> length n)
  778.           (%substring-move! string 0 n result 0)
  779.           (begin
  780.         (%substring-move! string 0 length result 0)
  781.         (let ((char (if (default-object? char) #\space char)))
  782.           (substring-fill! result length n char))))
  783.       result))))
  784.  
  785. (define (string-pad-left string n #!optional char)
  786.   (guarantee-string string 'STRING-PAD-LEFT)
  787.   (guarantee-index/string n 'STRING-PAD-LEFT)
  788.   (let ((length (string-length string)))
  789.     (if (fix:= length n)
  790.     string
  791.     (let ((result (string-allocate n))
  792.           (i (fix:- n length)))
  793.       (if (fix:< i 0)
  794.           (%substring-move! string (fix:- 0 i) length result 0)
  795.           (begin
  796.         (let ((char (if (default-object? char) #\space char)))
  797.           (substring-fill! result 0 i char))
  798.         (%substring-move! string 0 length result i)))
  799.       result))))
  800.  
  801. ;;;; String Search
  802.  
  803. (define (substring? pattern text)
  804.   (and (string-search-forward pattern text) #t))
  805.  
  806. (define (string-search-forward pattern text)
  807.   (guarantee-string pattern 'STRING-SEARCH-FORWARD)
  808.   (guarantee-string text 'STRING-SEARCH-FORWARD)
  809.   (%substring-search-forward text 0 (string-length text)
  810.                  pattern 0 (string-length pattern)))
  811.  
  812. (define (substring-search-forward pattern text tstart tend)
  813.   (guarantee-string pattern 'SUBSTRING-SEARCH-FORWARD)
  814.   (guarantee-substring text tstart tend 'SUBSTRING-SEARCH-FORWARD)
  815.   (%substring-search-forward text tstart tend
  816.                  pattern 0 (string-length pattern)))
  817.  
  818. (define (string-search-backward pattern text)
  819.   (guarantee-string pattern 'STRING-SEARCH-BACKWARD)
  820.   (guarantee-string text 'STRING-SEARCH-BACKWARD)
  821.   (%substring-search-backward text 0 (string-length text)
  822.                   pattern 0 (string-length pattern)))
  823.  
  824. (define (substring-search-backward pattern text tstart tend)
  825.   (guarantee-string pattern 'SUBSTRING-SEARCH-BACKWARD)
  826.   (guarantee-substring text tstart tend 'SUBSTRING-SEARCH-BACKWARD)
  827.   (%substring-search-backward text tstart tend
  828.                   pattern 0 (string-length pattern)))
  829.  
  830. (define (string-search-all pattern text)
  831.   (guarantee-string pattern 'STRING-SEARCH-ALL)
  832.   (guarantee-string text 'STRING-SEARCH-ALL)
  833.   (%bm-substring-search-all text 0 (string-length text)
  834.                 pattern 0 (string-length pattern)))
  835.  
  836. (define (substring-search-all pattern text tstart tend)
  837.   (guarantee-string pattern 'SUBSTRING-SEARCH-ALL)
  838.   (guarantee-substring text tstart tend 'SUBSTRING-SEARCH-ALL)
  839.   (%bm-substring-search-all text tstart tend
  840.                 pattern 0 (string-length pattern)))
  841.  
  842. (define (%substring-search-forward text tstart tend pattern pstart pend)
  843.   ;; Returns index of first matched char, or #F.
  844.   (if (fix:< (fix:- pend pstart) 4)
  845.       (%dumb-substring-search-forward text tstart tend pattern pstart pend)
  846.       (%bm-substring-search-forward text tstart tend pattern pstart pend)))
  847.  
  848. (define (%dumb-substring-search-forward text tstart tend pattern pstart pend)
  849.   (if (fix:= pstart pend)
  850.       0
  851.       (let* ((leader (string-ref pattern pstart))
  852.          (plen (fix:- pend pstart))
  853.          (tend (fix:- tend plen)))
  854.     (let loop ((tstart tstart))
  855.       (let ((tstart
  856.          (let find-leader ((tstart tstart))
  857.            (and (fix:<= tstart tend)
  858.             (if (char=? leader (string-ref text tstart))
  859.                 tstart
  860.                 (find-leader (fix:+ tstart 1)))))))
  861.         (and tstart
  862.          (if (substring=? text (fix:+ tstart 1) (fix:+ tstart plen)
  863.                   pattern (fix:+ pstart 1) pend)
  864.              tstart
  865.              (loop (fix:+ tstart 1)))))))))
  866.  
  867. (define (%substring-search-backward text tstart tend pattern pstart pend)
  868.   ;; Returns index following last matched char, or #F.
  869.   (if (fix:< (fix:- pend pstart) 4)
  870.       (%dumb-substring-search-backward text tstart tend pattern pstart pend)
  871.       (%bm-substring-search-backward text tstart tend pattern pstart pend)))
  872.  
  873. (define (%dumb-substring-search-backward text tstart tend pattern pstart pend)
  874.   (if (fix:= pstart pend)
  875.       0
  876.       (let* ((pend-1 (fix:- pend 1))
  877.          (trailer (string-ref pattern pend-1))
  878.          (plen (fix:- pend pstart))
  879.          (tstart+plen (fix:+ tstart plen)))
  880.     (let loop ((tend tend))
  881.       (let ((tend
  882.          (let find-trailer ((tend tend))
  883.            (and (fix:<= tstart+plen tend)
  884.             (if (char=? trailer (string-ref text (fix:- tend 1)))
  885.                 tend
  886.                 (find-trailer (fix:- tend 1)))))))
  887.         (and tend
  888.          (if (substring=? text (fix:- tend plen) (fix:- tend 1)
  889.                   pattern pstart pend-1)
  890.              tend
  891.              (loop (fix:- tend 1)))))))))
  892.  
  893. ;;;; Boyer-Moore String Search
  894.  
  895. ;;; Cormen, Leiserson, and Rivest, "Introduction to Algorithms",
  896. ;;; Chapter 34, "String Matching".
  897.  
  898. (define (%bm-substring-search-forward text tstart tend pattern pstart pend)
  899.   (let ((m (fix:- pend pstart))
  900.     (pstart-1 (fix:- pstart 1))
  901.     (pend-1 (fix:- pend 1))
  902.     (lambda* (compute-last-occurrence-function pattern pstart pend))
  903.     (gamma
  904.      (compute-good-suffix-function pattern pstart pend
  905.                        (compute-gamma0 pattern pstart pend))))
  906.     (let ((tend-m (fix:- tend m))
  907.       (m-1 (fix:- m 1)))
  908.       (let outer ((s tstart))
  909.     (and (fix:<= s tend-m)
  910.          (let inner ((pj pend-1) (tj (fix:+ s m-1)))
  911.            (if (fix:= (vector-8b-ref pattern pj) (vector-8b-ref text tj))
  912.            (if (fix:= pstart pj)
  913.                s
  914.                (inner (fix:- pj 1) (fix:- tj 1)))
  915.            (outer
  916.             (fix:+ s
  917.                (fix:max (fix:- (fix:- pj pstart-1)
  918.                        (lambda* (vector-8b-ref text tj)))
  919.                     (gamma (fix:- pj pstart))))))))))))
  920.  
  921. (define (%bm-substring-search-backward text tstart tend pattern pstart pend)
  922.   (let ((m (fix:- pend pstart))
  923.     (pend-1 (fix:- pend 1))
  924.     (rpattern (reverse-substring pattern pstart pend)))
  925.     (let ((tstart+m (fix:+ tstart m))
  926.       (lambda* (compute-last-occurrence-function rpattern 0 m))
  927.       (gamma
  928.        (compute-good-suffix-function rpattern 0 m
  929.                      (compute-gamma0 rpattern 0 m))))
  930.       (let outer ((s tend))
  931.     (and (fix:>= s tstart+m)
  932.          (let inner ((pj pstart) (tj (fix:- s m)))
  933.            (if (fix:= (vector-8b-ref pattern pj) (vector-8b-ref text tj))
  934.            (if (fix:= pend-1 pj)
  935.                s
  936.                (inner (fix:+ pj 1) (fix:+ tj 1)))
  937.            (outer
  938.             (fix:- s
  939.                (fix:max (fix:- (fix:- pend pj)
  940.                        (lambda* (vector-8b-ref text tj)))
  941.                     (gamma (fix:- pend-1 pj))))))))))))
  942.  
  943. (define (%bm-substring-search-all text tstart tend pattern pstart pend)
  944.   (let ((m (fix:- pend pstart))
  945.     (pstart-1 (fix:- pstart 1))
  946.     (pend-1 (fix:- pend 1))
  947.     (lambda* (compute-last-occurrence-function pattern pstart pend))
  948.     (gamma0 (compute-gamma0 pattern pstart pend)))
  949.     (let ((gamma (compute-good-suffix-function pattern pstart pend gamma0))
  950.       (tend-m (fix:- tend m))
  951.       (m-1 (fix:- m 1)))
  952.       (let outer ((s tstart) (occurrences '()))
  953.     (if (fix:<= s tend-m)
  954.         (let inner ((pj pend-1) (tj (fix:+ s m-1)))
  955.           (if (fix:= (vector-8b-ref pattern pj) (vector-8b-ref text tj))
  956.           (if (fix:= pstart pj)
  957.               (outer (fix:+ s gamma0) (cons s occurrences))
  958.               (inner (fix:- pj 1) (fix:- tj 1)))
  959.           (outer (fix:+ s
  960.                 (fix:max (fix:- (fix:- pj pstart-1)
  961.                         (lambda*
  962.                          (vector-8b-ref text tj)))
  963.                      (gamma (fix:- pj pstart))))
  964.              occurrences)))
  965.         (reverse! occurrences))))))
  966.  
  967. (define (compute-last-occurrence-function pattern pstart pend)
  968.   (let ((lam (make-vector 256 0)))
  969.     (do ((j pstart (fix:+ j 1)))
  970.     ((fix:= j pend))
  971.       (vector-set! lam
  972.            (vector-8b-ref pattern j)
  973.            (fix:+ (fix:- j pstart) 1)))
  974.     (lambda (symbol)
  975.       (vector-ref lam symbol))))
  976.  
  977. (define (compute-good-suffix-function pattern pstart pend gamma0)
  978.   (let ((m (fix:- pend pstart)))
  979.     (let ((pi
  980.        (compute-prefix-function (reverse-substring pattern pstart pend)
  981.                     0 m))
  982.       (gamma (make-vector m gamma0))
  983.       (m-1 (fix:- m 1)))
  984.       (do ((l 0 (fix:+ l 1)))
  985.       ((fix:= l m))
  986.     (let ((j (fix:- m-1 (vector-ref pi l)))
  987.           (k (fix:- (fix:+ 1 l) (vector-ref pi l))))
  988.       (if (fix:< k (vector-ref gamma j))
  989.           (vector-set! gamma j k))))
  990.       (lambda (index)
  991.     (vector-ref gamma index)))))
  992.  
  993. (define (compute-gamma0 pattern pstart pend)
  994.   (let ((m (fix:- pend pstart)))
  995.     (fix:- m
  996.        (vector-ref (compute-prefix-function pattern pstart pend)
  997.                (fix:- m 1)))))
  998.  
  999. (define (compute-prefix-function pattern pstart pend)
  1000.   (let* ((m (fix:- pend pstart))
  1001.      (pi (make-vector m)))
  1002.     (vector-set! pi 0 0)
  1003.     (let outer ((k 0) (q 1))
  1004.       (if (fix:< q m)
  1005.       (let ((k
  1006.          (let ((pq (vector-8b-ref pattern (fix:+ pstart q))))
  1007.            (let inner ((k k))
  1008.              (cond ((fix:= pq (vector-8b-ref pattern (fix:+ pstart k)))
  1009.                 (fix:+ k 1))
  1010.                ((fix:= k 0)
  1011.                 k)
  1012.                (else
  1013.                 (inner (vector-ref pi (fix:- k 1)))))))))
  1014.         (vector-set! pi q k)
  1015.         (outer k (fix:+ q 1)))))
  1016.     pi))
  1017.  
  1018. ;;;; External Strings
  1019.  
  1020. (define external-strings)
  1021. (define (initialize-package!)
  1022.   (set! external-strings
  1023.     (make-gc-finalizer (ucode-primitive deallocate-external-string)))
  1024.   unspecific)
  1025.  
  1026. (define-structure external-string
  1027.   (descriptor #f read-only #t)
  1028.   (length #f read-only #t))
  1029.  
  1030. (define (allocate-external-string n-bytes)
  1031.   (without-interrupts
  1032.    (lambda ()
  1033.      (let ((descriptor ((ucode-primitive allocate-external-string) n-bytes)))
  1034.        (let ((xstring (make-external-string descriptor n-bytes)))
  1035.      (add-to-gc-finalizer! external-strings xstring descriptor)
  1036.      xstring)))))
  1037.  
  1038. (define (xstring? object)
  1039.   (or (string? object)
  1040.       (external-string? object)))
  1041.  
  1042. (define (xstring-length xstring)
  1043.   (cond ((string? xstring)
  1044.      (string-length xstring))
  1045.     ((external-string? xstring)
  1046.      (external-string-length xstring))
  1047.     (else
  1048.      (error:wrong-type-argument xstring "xstring" 'XSTRING-LENGTH))))
  1049.  
  1050. (define (xstring-move! xstring1 xstring2 start2)
  1051.   (xsubstring-move! xstring1 0 (xstring-length xstring1) xstring2 start2))
  1052.  
  1053. (define (xsubstring-move! xstring1 start1 end1 xstring2 start2)
  1054.   (let ((deref
  1055.      (lambda (xstring)
  1056.        (if (external-string? xstring)
  1057.            (external-string-descriptor xstring)
  1058.            xstring))))
  1059.     (cond ((or (not (eq? xstring2 xstring1)) (< start2 start1))
  1060.        (substring-move-left! (deref xstring1) start1 end1
  1061.                  (deref xstring2) start2))
  1062.       ((> start2 start1)
  1063.        (substring-move-right! (deref xstring1) start1 end1
  1064.                   (deref xstring2) start2)))))
  1065.  
  1066. ;;;; Guarantors
  1067. ;;
  1068. ;; The guarantors are integrated.  Most are structured as combination of
  1069. ;; simple tests which the compiler can open-code, followed by a call to a
  1070. ;; GUARANTEE-.../FAIL version which does the tests again to signal a
  1071. ;; menaingful message. Structuring the code this way significantly
  1072. ;; reduces code bloat from large integrated procedures.
  1073.  
  1074. (define-integrable (guarantee-string object procedure)
  1075.   (if (not (string? object))
  1076.       (error:wrong-type-argument object "string" procedure)))
  1077.  
  1078. (define-integrable (guarantee-2-strings object1 object2 procedure)
  1079.   (if (not (and (string? object1) (string? object2)))
  1080.       (guarantee-2-strings/fail object1 object2 procedure)))
  1081.  
  1082. (define (guarantee-2-strings/fail object1 object2 procedure)
  1083.   (cond ((not (string? object1))
  1084.      (error:wrong-type-argument object1 "string" procedure))
  1085.     ((not (string? object2))
  1086.      (error:wrong-type-argument object2 "string" procedure))))
  1087.  
  1088. (define-integrable (guarantee-index/string object procedure)
  1089.   (if (not (index-fixnum? object))
  1090.       (guarantee-index/string/fail object procedure)))
  1091.  
  1092. (define (guarantee-index/string/fail object procedure)
  1093.   (error:wrong-type-argument object "valid string index"
  1094.                  procedure))
  1095.  
  1096. (define-integrable (guarantee-substring string start end procedure)
  1097.   (if (not (and (string? string)
  1098.         (index-fixnum? start)
  1099.         (index-fixnum? end)
  1100.         (fix:<= start end)
  1101.         (fix:<= end (string-length string))))
  1102.       (guarantee-substring/fail string start end procedure)))
  1103.  
  1104. (define-integrable (guarantee-2-substrings string1 start1 end1
  1105.                        string2 start2 end2
  1106.                        procedure)
  1107.   (guarantee-substring string1 start1 end1 procedure)
  1108.   (guarantee-substring string2 start2 end2 procedure))
  1109.  
  1110. (define (guarantee-substring/fail string start end procedure)
  1111.   (guarantee-string string procedure)
  1112.   (guarantee-index/string start procedure)
  1113.   (guarantee-index/string end procedure)
  1114.   (if (not (fix:<= end (string-length string)))
  1115.       (error:bad-range-argument end procedure))
  1116.   (if (not (fix:<= start end))
  1117.       (error:bad-range-argument start procedure)))
  1118.  
  1119. (define-integrable (guarantee-char-set object procedure)
  1120.   (if (not (char-set? object))
  1121.       (error:wrong-type-argument object "character set" procedure)))