ikarus/src/ikarus.chars.ss

(library (ikarus chars)
  (export char=? char<? char<=? char>? char>=? ;char-whitespace?
          char->integer integer->char
          ;char-alphabetic? 
          char-downcase)
  (import 
    (except (ikarus)
      char=? char<? char<=? char>? char>=?
      integer->char char->integer
      ;char-whitespace? char-alphabetic?
      char-downcase)
    (ikarus system $pairs)
    (ikarus system $chars)
    (ikarus system $fx))

  (define integer->char
    (lambda (n)
      (cond
        [(not (fixnum? n)) (error 'integer->char "invalid argument ~s" n)]
        [($fx< n 0) (error 'integer->char "~s is negative" n)]
        [($fx<= n #xD7FF) ($fixnum->char n)]
        [($fx< n #xE000)
         (error 'integer->char "~s does not have a unicode representation" n)]
        [($fx<= n #x10FFFF) ($fixnum->char n)]
        [else (error 'integer->char 
                "~s does not have a unicode representation" n)])))
  
  (define char->integer 
    (lambda (x) 
      (unless (char? x)
        (error 'char->integer "~s is not a character" x))
      ($char->fixnum x)))

  ;;; FIXME: this file is embarrasing
  (define char=?
    (let ()
      (define (err x)
        (error 'char=? "~s is not a character" x))
      (case-lambda
        [(c1 c2)
         (if (char? c1)
             (if (char? c2)
                 ($char= c1 c2)
                 (err c2))
             (err c1))]
        [(c1 c2 c3)
         (if (char? c1)
             (if (char? c2)
                 (if (char? c3)
                     (and ($char= c1 c2)
                          ($char= c2 c3))
                     (err c3))
                 (err c2))
             (err c1))]
        [(c1 . c*)
         (if (char? c1)
             (let f ([c* c*])
               (or (null? c*) 
                   (let ([c2 ($car c*)])
                     (if (char? c2)
                         (if ($char= c1 c2)
                             (f ($cdr c*))
                             (let g ([c* ($cdr c*)])
                               (if (null? c*)
                                   #f
                                   (if (char? ($car c*))
                                       (g ($cdr c*))
                                       (err ($car c*))))))
                         (err c2)))))
             (err c1))])))

  (define char<?
    (let ()
      (define (err x)
        (error 'char<? "~s is not a character" x))
      (case-lambda
        [(c1 c2)
         (if (char? c1)
             (if (char? c2)
                 ($char< c1 c2)
                 (err c2))
             (err c1))]
        [(c1 c2 c3)
         (if (char? c1)
             (if (char? c2)
                 (if (char? c3)
                     (and ($char< c1 c2)
                          ($char< c2 c3))
                     (err c3))
                 (err c2))
             (err c1))]
        [(c1 . c*)
         (if (char? c1)
             (let f ([c1 c1] [c* c*])
               (or (null? c*) 
                   (let ([c2 ($car c*)])
                     (if (char? c2)
                         (if ($char< c1 c2)
                             (f c2 ($cdr c*))
                             (let g ([c* ($cdr c*)])
                               (if (null? c*)
                                   #f
                                   (if (char? ($car c*))
                                       (g ($cdr c*))
                                       (err ($car c*))))))
                         (err c2)))))
             (err c1))])))

  (define char<=?
    (let ()
      (define (err x)
        (error 'char<=? "~s is not a character" x))
      (case-lambda
        [(c1 c2)
         (if (char? c1)
             (if (char? c2)
                 ($char<= c1 c2)
                 (err c2))
             (err c1))]
        [(c1 c2 c3)
         (if (char? c1)
             (if (char? c2)
                 (if (char? c3)
                     (and ($char<= c1 c2)
                          ($char<= c2 c3))
                     (err c3))
                 (err c2))
             (err c1))]
        [(c1 . c*)
         (if (char? c1)
             (let f ([c1 c1] [c* c*])
               (or (null? c*) 
                   (let ([c2 ($car c*)])
                     (if (char? c2)
                         (if ($char<= c1 c2)
                             (f c2 ($cdr c*))
                             (let g ([c* ($cdr c*)])
                               (if (null? c*)
                                   #f
                                   (if (char? ($car c*))
                                       (g ($cdr c*))
                                       (err ($car c*))))))
                         (err c2)))))
             (err c1))])))

  (define char>?
    (let ()
      (define (err x)
        (error 'char>? "~s is not a character" x))
      (case-lambda
        [(c1 c2)
         (if (char? c1)
             (if (char? c2)
                 ($char> c1 c2)
                 (err c2))
             (err c1))]
        [(c1 c2 c3)
         (if (char? c1)
             (if (char? c2)
                 (if (char? c3)
                     (and ($char> c1 c2)
                          ($char> c2 c3))
                     (err c3))
                 (err c2))
             (err c1))]
        [(c1 . c*)
         (if (char? c1)
             (let f ([c1 c1] [c* c*])
               (or (null? c*) 
                   (let ([c2 ($car c*)])
                     (if (char? c2)
                         (if ($char> c1 c2)
                             (f c2 ($cdr c*))
                             (let g ([c* ($cdr c*)])
                               (if (null? c*)
                                   #f
                                   (if (char? ($car c*))
                                       (g ($cdr c*))
                                       (err ($car c*))))))
                         (err c2)))))
             (err c1))])))

  (define char>=?
    (let ()
      (define (err x)
        (error 'char>=? "~s is not a character" x))
      (case-lambda
        [(c1 c2)
         (if (char? c1)
             (if (char? c2)
                 ($char>= c1 c2)
                 (err c2))
             (err c1))]
        [(c1 c2 c3)
         (if (char? c1)
             (if (char? c2)
                 (if (char? c3)
                     (and ($char>= c1 c2)
                          ($char>= c2 c3))
                     (err c3))
                 (err c2))
             (err c1))]
        [(c1 . c*)
         (if (char? c1)
             (let f ([c1 c1] [c* c*])
               (or (null? c*) 
                   (let ([c2 ($car c*)])
                     (if (char? c2)
                         (if ($char>= c1 c2)
                             (f c2 ($cdr c*))
                             (let g ([c* ($cdr c*)])
                               (if (null? c*)
                                   #f
                                   (if (char? ($car c*))
                                       (g ($cdr c*))
                                       (err ($car c*))))))
                         (err c2)))))
             (err c1))])))


  ;;; XXX (define char-whitespace?
  ;;; XXX   (lambda (c)
  ;;; XXX     (cond 
  ;;; XXX       [(memq c '(#\space #\tab #\newline #\return)) #t]
  ;;; XXX       [(char? c) #f]
  ;;; XXX       [else
  ;;; XXX        (error 'char-whitespace? "~s is not a character" c)])))
  
  ;;; XXX (define char-alphabetic?
  ;;; XXX   (lambda (c)
  ;;; XXX     (cond
  ;;; XXX       [(char? c)
  ;;; XXX        (cond
  ;;; XXX          [($char<= #\a c) ($char<= c #\z)]
  ;;; XXX          [($char<= #\A c) ($char<= c #\Z)]
  ;;; XXX          [else #f])]
  ;;; XXX       [else 
  ;;; XXX        (error 'char-alphabetic?  "~s is not a character" c)])))
  
  (define char-downcase
    (lambda (c)
      (cond
        [(char? c)
         (cond
           [(and ($char<= #\A c) ($char<= c #\Z))
            ($fixnum->char 
              ($fx+ ($char->fixnum c)
                    ($fx- ($char->fixnum #\a)
                          ($char->fixnum #\A))))]
           [else c])]
        [else 
         (error 'char-downcase "~s is not a character" c)])))

)