;*---------------------------------------------------------------------*/
;*    serrano/prgm/project/bigloo/recette/string.scm                   */
;*                                                                     */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Tue Nov  3 10:18:56 1992                          */
;*    Last change :  Fri Nov 14 17:31:03 2003 (serrano)                */
;*                                                                     */
;*    On teste differentes operations sur les chaines de caracteres    */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*    Le module                                                        */
;*---------------------------------------------------------------------*/
(module string
   (import  (main "main.scm"))
   (include "test.sch")
   (export  (test-string)))

(define (scheme-id->c-id string)
   (let* ((nstring (if (and (not (char-alphabetic? (string-ref string 0)))
			    (not (char=? (string-ref string 0) #\_)))
		       (string-append "_" string)
		       string))
	  (len     (string-length nstring))
	  (rg      #f)
	  (res     (make-string len)))
      (let loop ((i 0))
	 (if (=fx i len)
	     (remove__ (if rg
			   (string-append
			    (string-downcase res)
			    (string-append
			     "_"
			     (integer->string 7)))
			   (string-downcase res)))
	     (let ((c (string-ref nstring i)))
		(cond
		   ((or (and (char>=? c #\A)
			     (char<=? c #\Z))
			(and (char>=? c #\a)
			     (char<=? c #\z))
			(and (char>=? c #\0)
			     (char<=? c #\9))
			(char=? c #\_))
		    (string-set! res i (string-ref nstring i))
		    (loop (+fx i 1)))
		   (else
		    (set! rg #t)
		    (string-set! res i #\_) 
		    (loop (+fx i 1)))))))))

(define (remove__ string)
   (cond
      ((not (>=fx (string-length string) 6))
       string)
      ((not (char=? (string-ref string 0) #\_))
       string)
      ((not (char=? (string-ref string 1) #\_))
       string)
      ((and (not (char=? (string-ref string 2) #\i))
	    (not (char=? (string-ref string 2) #\f)))
       string)
      ((and (not (char=? (string-ref string 3) #\n))
	    (not (char=? (string-ref string 3) #\i)))
       string)
      ((and (not (char=? (string-ref string 4) #\i))
	    (not (char=? (string-ref string 4) #\n)))
       string)
      ((and (not (char=? (string-ref string 5) #\t))
	    (not (char=? (string-ref string 5) #\i)))
       string)
      ((not (char=? (string-ref string 6) #\_))
       string)
      (else
       (string-append "_n_o_f_u_c_k_i_n_g___init_or_fini" string))))

;*---------------------------------------------------------------------*/
;*    8bits->7bits ...                                                 */
;*---------------------------------------------------------------------*/
(define (8bits->7bits string::bstring)
   (let ((len (string-length string)))
      (let loop ((i 0))
         (if (=fx i len)
             string
             (begin 
                (case (string-ref string i)
                   ((#\é #\è)
                    (string-set! string i #\e))
                   ((#\É #\È)
                    (string-set! string i #\E))
                   ((#\à)
                    (string-set! string i #\a))
                   ((#\À)
                    (string-set! string i #\A))
                   ((#\û #\ü)
                    (string-set! string i #\u))
                   ((#\Û #\Ü)
                    (string-set! string i #\U))
                   ((#\î #\ï)
                    (string-set! string i #\i))
                   ((#\Î #\Ï)
                    (string-set! string i #\I))
                   ((#\ö #\ô)
                    (string-set! string i #\o))
                   ((#\Ö #\Ô)
                    (string-set! string i #\O))
                   ((#\ç)
                    (string-set! string i #\c))
                   ((#\C)
                    (string-set! string i #\C)))
                (loop (+fx i 1)))))))

;*---------------------------------------------------------------------*/
;*    test-string-copy ...                                             */
;*---------------------------------------------------------------------*/
(define (test-string-copy str)
   (string-copy str))

;*---------------------------------------------------------------------*/
;*    test-string ...                                                  */
;*---------------------------------------------------------------------*/
(define (test-string)
   (test-module "string" "string.scm")
   (test "string=?" (string=? "toto n'est pas content"
			      "toto n'est pas content")
	 #t)
   (test "string=?" (string=? "ToTo" "tOtO") #f)
   (test "string=?" (let ((s (make-string 3 (integer->char 0))))
		       (string=? s #"\000\000\000"))
	 #t)
   (test "string=?" (let ((s (make-string 3 (integer->char 0))))
		       (string=? s #"\000\001\000"))
	 #f)
   (test "string-length" (string-length "12345") 5)
   (test "string" (equal? "toto n'est pas content" "toto est content")
	 #f)
   (test "make-string" (string-ref (make-string 1 #\a) 0) #\a)
   (test "string-append" (string-append "Toto " "est content")
	 "Toto est content")
   (test "string-append" (string-append "toto" " n'est" " pas" " content")
	 "toto n'est pas content")
   (test "string-upcase" (string-upcase "toto TOTO ToTo") "TOTO TOTO TOTO")
   (test "string-ci=?"     (string-ci=? "Toto" "tOtO") #t)
   (test "string-set"    (let ((s (string-copy "0123456789")))
			    (string-set! s 0 (string-ref s 1))
			    s)
	 "1123456789")
   (test "string-copy" (test-string-copy (make-string 3 #\6)) "666")
   (test "list->string" (list->string '(#\t #\o #\t #\o)) "toto")
   (test "string->list" (string->list "toto") '(#\t #\o #\t #\o))
   (test "string->list" (string->list "-$>$") '(#\- #\$ #\> #\$))
   (test "string->string" (list->string (string->list "tot oto")) "tot oto")
   (test "string->integer" (string->integer "01234") 1234)
   (test "integer->string" (integer->string 0) "0")
   (test "integer->string" (integer->string 1) "1")
   (test "integer->string" (integer->string -1) "-1")
   (test "integer->string" (integer->string 1234) "1234")
   (test "integer->string" (integer->string -1234) "-1234")
   (test "string->real" (string->real "1234.25") 1234.25)
   (test "real->string" (real->string 1234.25) "1234.25")
   (test "substring" (substring "0123456789" 1 5) "1234")
   (let ((dst (make-string 10 #\0))
	 (src (make-string 5 #\1)))
      (test "blit-string" (begin (blit-string! src 1 dst 1 3)
				 dst)
	    "0111000000"))
   (test "string<?" (string<? "012345" "123456") #t)
   (test "string<=?" (string<=? "012345" "012345") #t)
   (test "string>?" (string>? "012345" "123456") #f)
   (test "string>=?" (string<=? "012345" "012345") #t)
   (test "string-ci<?" (string-ci<? "abcdef" "ABCDEF") #f)
   (test "string-ci<?" (string-ci<? "abcdef" "ABCDEG") #t)
   (test "string-ci<=?" (string-ci<=? "A" "A") #t)
   (test "string-ci<=?" (string-ci<=? "abcdef" "ABCDEG") #t)
   (test "string-ci<=?" (string-ci<=? "abcdef" "ABCDEG") #t)
   (test "string-ci>?" (string-ci>? "abcdef" "ABCDEG") #f)
   (test "string-ci>?" (string-ci>? "abcdef" "ABCDEG") #f)
   (test "string-ci>=?" (string-ci>=? "abcdef" "ABCDEG") #f)
   (test "string-ci>=?" (string-ci>=? "abcdef" "ABCDEF") #t)
   (test "string-ci=?" (string-ci=? "toto" "titi") #f)
   (test "string-ci=?" (string-ci=? "toto" "Toto") #t)
   (test "string-ci=?" (string-ci=? "toto" "tot") #f)
   (test "substring=?" (substring=? "abcdef" "abcd" 3) #t)
   (test "substring=?" (substring=? "abcdef" "Abcd" 3) #f)
   (test "substring-ci=?" (substring-ci=? "abcdef" "abc" 4) #f)
   (test "substring-ci=?" (substring-ci=? "abcdef" "abcd" 3) #t)
   (test "substring-ci=?" (substring-ci=? "abcdef" "Abcd" 3) #t)
   (test "substring-ci=?" (substring-ci=? "abcdef" "Abc" 4) #f)
   (test "8bits" (8bits->7bits "ÉéÈèÏï") "EeEeIi")
   (test "8bits-string<?" (string<? "abecd" "abécd") #t)
   (test "8bits-string<=?" (string<=? "abecd" "abécd") #t)
   (test "8bits-string>?" (string>? "abécd" "abecd") #t)
   (test "8bits-string>=?" (string>=? "abécd" "abecd") #t)
   (test "8bits-string-ci<?" (string-ci<? "abecd" "abécd") #t)
   (test "8bits-string-ci<=?" (string-ci<=? "abecd" "abécd") #t)
   (test "8bits-string-ci>?" (string-ci>? "abécd" "abecd") #t)
   (test "8bits-string-ci>=?" (string-ci>=? "abécd" "abecd") #t)
   (test "foreign" (let ((x "\n\t\\\"")) (string->list x))
	 '(#\newline #\tab #\\ #\"))
   (test "foreign" (let ((x #"\n\\\"")) (string->list x))
	 '(#\newline #\\ #\"))
   (test "symbol" (symbol->string (string->symbol "tOtO")) "tOtO")
   (test "symbol" (eq? (string->symbol "ToTo") 'toto) #f)
   (test "symbol" (eq? (string->symbol "TOTO") 'TOTO) #t)
   (test "string-copy" (string-copy "toto n'est pas content")
	 "toto n'est pas content")
   (test "escape" (string-length #"\000") 1)
   (test "escape" (string-length #"\x00") 1)
   (test "escape" (char->integer (string-ref #"\000" 0)) 0)
   (test "escape" (char->integer (string-ref #"\003" 0)) 3)
   (test "escape" (char->integer (string-ref #"\x03" 0)) 3)
   (test "escape" (char->integer (string-ref #"\x7f" 0)) #x7f)
   (test "escape" (char->integer (string-ref #"\x7F" 0)) #x7f)
   (test "escape" (char->integer (string-ref #"\X7e" 0)) #x7e)
   (test "escape" (char->integer (string-ref #"\X7E" 0)) #x7e)
   (test "escape" (char->integer (string-ref #"\XaE" 0)) #xae)
   (test "escape" (char->integer (string-ref #"\XAE" 0)) #xae)
   (test "escape(8bits)" (list "böig") '("böig"))
   (test "id"
	 (scheme-id->c-id "INITIALIZE-IMPORTED-MODULES!_FOO")
	 "initialize_imported_modules__foo_7")
   (test "trigraph" "??-" (string-append "?" "?" "-"))
   (test "suffix" (suffix "toto.scm") "scm")
   (test "suffix" (suffix "toto") "")
   (test "suffix" (suffix (make-file-name "." "toto")) "")
   (test "suffix" (suffix (make-file-name ".." "toto")) "")
   (test "suffix" (suffix (string-append (string (file-separator)) "etc" (string (file-separator)) "rc.d" (string (file-separator)) "rc.3" (string (file-separator)) "K70syslogd")) "")
   (test "path" (unix-path->list ".") '("."))
   (test "path" (unix-path->list "/:.:/usr/local") '("/" "." "/usr/local"))
   (test "string-compare3.1" (< (string-compare3 "abc" "def") 0) #t)
   (test "string-compare3.2" (> (string-compare3 "def" "abc") 0) #t)
   (test "string-compare3.3" (= (string-compare3 "def" "abc") 0) #f)
   (test "string-compare3.4" (= (string-compare3 "def" "def") 0) #t)
   (test "string-compare3.5" (< (string-compare3 "abc" "abci") 0) #t)
   (test "string-compare3.6" (< (string-compare3 "abc" "abd") 0) #t)
   (test "string-compare3.7" (> (string-compare3 "abci" "abc") 0) #t)
   (test "string-compare3.8" (> (string-compare3 "abd" "abc") 0) #t)
   (test "string-compare3-ci.1" (< (string-compare3-ci "abc" "DeF") 0) #t)
   (test "string-compare3-ci.2" (> (string-compare3-ci "def" "ABC") 0) #t)
   (test "string-compare3-ci.3" (= (string-compare3-ci "def" "ABC") 0) #f)
   (test "string-compare3-ci.4" (= (string-compare3-ci "def" "dEF") 0) #t)
   (test "string-compare3-ci.5" (< (string-compare3-ci "ABC" "AbCi") 0) #t)
   (test "string-compare3-ci.6" (< (string-compare3-ci "abc" "ABD") 0) #t)
   (test "string-compare3-ci.7" (> (string-compare3-ci "ABCI" "ABC") 0) #t)
   (test "string-compare3-ci.8" (> (string-compare3-ci "aBd" "abc") 0) #t))

