git.gag.com Git - fw/altos/blob - src/scheme/ao_scheme_char.scheme

   1 ;
   2 ; Copyright © 2018 Keith Packard <keithp@keithp.com>
   3 ;
   4 ; This program is free software; you can redistribute it and/or modify
   5 ; it under the terms of the GNU General Public License as published by
   6 ; the Free Software Foundation, either version 2 of the License, or
   7 ; (at your option) any later version.
   8 ;
   9 ; This program is distributed in the hope that it will be useful, but
  10 ; WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ; General Public License for more details.
  13 ;
  14 ; Char primitives placed in ROM
  15
  16 (define char? integer?)
  17
  18 (_??_ (char? #\q) #t)
  19 (_??_ (char? "h") #f)
  20
  21 (define (char-upper-case? c) (<= #\A c #\Z))
  22
  23 (_??_ (char-upper-case? #\a) #f)
  24 (_??_ (char-upper-case? #\B) #t)
  25 (_??_ (char-upper-case? #\0) #f)
  26 (_??_ (char-upper-case? #\space) #f)
  27
  28 (define (char-lower-case? c) (<= #\a c #\a))
  29
  30 (_??_ (char-lower-case? #\a) #t)
  31 (_??_ (char-lower-case? #\B) #f)
  32 (_??_ (char-lower-case? #\0) #f)
  33 (_??_ (char-lower-case? #\space) #f)
  34
  35 (define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))
  36
  37 (_??_ (char-alphabetic? #\a) #t)
  38 (_??_ (char-alphabetic? #\B) #t)
  39 (_??_ (char-alphabetic? #\0) #f)
  40 (_??_ (char-alphabetic? #\space) #f)
  41
  42 (define (char-numeric? c) (<= #\0 c #\9))
  43
  44 (_??_ (char-numeric? #\a) #f)
  45 (_??_ (char-numeric? #\B) #f)
  46 (_??_ (char-numeric? #\0) #t)
  47 (_??_ (char-numeric? #\space) #f)
  48
  49 (define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c)))
  50
  51 (_??_ (char-whitespace? #\a) #f)
  52 (_??_ (char-whitespace? #\B) #f)
  53 (_??_ (char-whitespace? #\0) #f)
  54 (_??_ (char-whitespace? #\space) #t)
  55
  56 (define char->integer (macro (v) v))
  57 (define integer->char char->integer)
  58
  59 (define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
  60
  61 (_??_ (char-upcase #\a) #\A)
  62 (_??_ (char-upcase #\B) #\B)
  63 (_??_ (char-upcase #\0) #\0)
  64 (_??_ (char-upcase #\space) #\space)
  65
  66 (define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))
  67
  68 (_??_ (char-downcase #\a) #\a)
  69 (_??_ (char-downcase #\B) #\b)
  70 (_??_ (char-downcase #\0) #\0)
  71 (_??_ (char-downcase #\space) #\space)
  72
  73 (define (digit-value c)
  74   (if (char-numeric? c)
  75       (- c #\0)
  76       #f)
  77   )
  78
  79 (_??_ (digit-value #\1) 1)
  80 (_??_ (digit-value #\a) #f)