X-Git-Url: https://git.gag.com/?a=blobdiff_plain;f=src%2Fscheme%2Fao_scheme_char.scheme;fp=src%2Fscheme%2Fao_scheme_char.scheme;h=c0353834a2b7fce7be11f84a5ca9022f88575133;hb=16061947d4376b41e596d87f97ec53ec29d17644;hp=0000000000000000000000000000000000000000;hpb=39df849f0717d92a7d5bdf8aa5904bd4db1b467f;p=fw%2Faltos

diff --git a/src/scheme/ao_scheme_char.scheme b/src/scheme/ao_scheme_char.scheme
new file mode 100644
index 00000000..c0353834
--- /dev/null
+++ b/src/scheme/ao_scheme_char.scheme
@@ -0,0 +1,80 @@
+;
+; Copyright © 2018 Keith Packard <keithp@keithp.com>
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation, either version 2 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful, but
+; WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+; General Public License for more details.
+;
+; Char primitives placed in ROM
+
+(define char? integer?)
+
+(_??_ (char? #\q) #t)
+(_??_ (char? "h") #f)
+
+(define (char-upper-case? c) (<= #\A c #\Z))
+
+(_??_ (char-upper-case? #\a) #f)
+(_??_ (char-upper-case? #\B) #t)
+(_??_ (char-upper-case? #\0) #f)
+(_??_ (char-upper-case? #\space) #f)
+
+(define (char-lower-case? c) (<= #\a c #\a))
+
+(_??_ (char-lower-case? #\a) #t)
+(_??_ (char-lower-case? #\B) #f)
+(_??_ (char-lower-case? #\0) #f)
+(_??_ (char-lower-case? #\space) #f)
+
+(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))
+
+(_??_ (char-alphabetic? #\a) #t)
+(_??_ (char-alphabetic? #\B) #t)
+(_??_ (char-alphabetic? #\0) #f)
+(_??_ (char-alphabetic? #\space) #f)
+
+(define (char-numeric? c) (<= #\0 c #\9))
+
+(_??_ (char-numeric? #\a) #f)
+(_??_ (char-numeric? #\B) #f)
+(_??_ (char-numeric? #\0) #t)
+(_??_ (char-numeric? #\space) #f)
+
+(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c)))
+
+(_??_ (char-whitespace? #\a) #f)
+(_??_ (char-whitespace? #\B) #f)
+(_??_ (char-whitespace? #\0) #f)
+(_??_ (char-whitespace? #\space) #t)
+
+(define char->integer (macro (v) v))
+(define integer->char char->integer)
+
+(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
+
+(_??_ (char-upcase #\a) #\A)
+(_??_ (char-upcase #\B) #\B)
+(_??_ (char-upcase #\0) #\0)
+(_??_ (char-upcase #\space) #\space)
+
+(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))
+
+(_??_ (char-downcase #\a) #\a)
+(_??_ (char-downcase #\B) #\b)
+(_??_ (char-downcase #\0) #\0)
+(_??_ (char-downcase #\space) #\space)
+
+(define (digit-value c)
+  (if (char-numeric? c)
+      (- c #\0)
+      #f)
+  )
+
+(_??_ (digit-value #\1) 1)
+(_??_ (digit-value #\a) #f)