(FILECREATED "28-Oct-85 21:29:14" {ERIS}<LISPCORE>LIBRARY>CMLCHARACTER.;18 13279
changes to: (FNS CHAR-NAME NAME-CHAR DIGIT-CHAR STANDARD-CHAR-P GRAPHIC-CHAR-P ALPHA-CHAR-P
ALPHANUMERICP CHAR-CODE CHAR= CHAR/= CHAR< CHAR> CHAR>= CHAR<=
CHARACTER.PRINT CHARCODE.UNDECODE)
(VARS CMLCHARACTERCOMS)
previous date: "23-Oct-85 15:07:57" {ERIS}<LISPCORE>LIBRARY>CMLCHARACTER.;14)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLCHARACTERCOMS)
(RPAQQ CMLCHARACTERCOMS [(RECORDS CHARACTER)
(INITVARS (\CODE-CHAR-HASH (HASHARRAY 512)))
(ADDVARS (\ALPHACHARSETS 38 39 36 37))
(CONSTANTS (CHAR-CODE-LIMIT 65536)
(CHAR-FONT-LIMIT 1)
(CHAR-BITS-LIMIT 1)
(CHAR-CONTROL-BIT 0)
(CHAR-META-BIT 0)
(CHAR-SUPER-BIT 0)
(CHAR-HYPER-BIT 0))
(FNS STANDARD-CHAR-P GRAPHIC-CHAR-P STRING-CHAR-P ALPHA-CHAR-P ALPHANUMERICP CODE-CHAR
CHAR-EQUAL CHAR-FONT CHAR-GREATERP CHAR-LESSP CHAR-BITS CHAR-CODE MAKE-CHAR CL:CHARACTER
CHAR= CHAR/= CHAR< CHAR> CHAR>= CHAR<= DIGIT-CHAR-P INT-CHAR UPPER-CASE-P LOWER-CASE-P
BOTH-CASE-P NAME-CHAR DIGIT-CHAR CHAR-NAME CHAR-NOT-EQUAL CHAR-NOT-GREATERP
CHAR-NOT-LESSP CHAR-INT CHAR-DOWNCASE CHAR-UPCASE CHAR-BIT SET-CHAR-BIT CHARACTERP)
(FNS CHARACTER.PRINT CHARCODE.UNDECODE)
[P (SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER))
(NTYPX (CODE-CHAR 0 0 0]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA DIGIT-CHAR CHAR<= CHAR>= CHAR> CHAR< CHAR/= CHAR= CHAR-NOT-LESSP
CHAR-NOT-GREATERP CHAR-NOT-EQUAL CHAR-LESSP CHAR-GREATERP CHAR-EQUAL]
)
[DECLARE: EVAL@COMPILE
(ACCESSFNS CHARACTER [(CODE (\LOLOC (\DTEST DATUM (QUOTE CHARACTER]
(CREATE (\VAG2 \CHARHI CODE))
(INIT (DEFPRINT (QUOTE CHARACTER)
(QUOTE CHARACTER.PRINT))))
]
(DEFPRINT (QUOTE CHARACTER)
(QUOTE CHARACTER.PRINT))
(RPAQ? \CODE-CHAR-HASH (HASHARRAY 512))
(ADDTOVAR \ALPHACHARSETS 38 39 36 37)
(DECLARE: EVAL@COMPILE
(RPAQQ CHAR-CODE-LIMIT 65536)
(RPAQQ CHAR-FONT-LIMIT 1)
(RPAQQ CHAR-BITS-LIMIT 1)
(RPAQQ CHAR-CONTROL-BIT 0)
(RPAQQ CHAR-META-BIT 0)
(RPAQQ CHAR-SUPER-BIT 0)
(RPAQQ CHAR-HYPER-BIT 0)
(CONSTANTS (CHAR-CODE-LIMIT 65536)
(CHAR-FONT-LIMIT 1)
(CHAR-BITS-LIMIT 1)
(CHAR-CONTROL-BIT 0)
(CHAR-META-BIT 0)
(CHAR-SUPER-BIT 0)
(CHAR-HYPER-BIT 0))
)
(DEFINEQ
(STANDARD-CHAR-P
[LAMBDA (CHAR) (* lmm "28-Oct-85 20:42")
(NOT (NULL (FMEMB (fetch (CHARACTER CODE) of CHAR)
(CONSTANT (CHCON
"!%"#%%'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]↑←`abcdefghijklmnopqrstuvwxyz{|}~
"])
(GRAPHIC-CHAR-P
[LAMBDA (CHAR) (* raf "23-Oct-85 15:03")
(LET [(CODE (LOGAND 255 (fetch (CHARACTER CODE) of CHAR]
(AND (GREATERP CODE 23)
(OR (LESSP CODE 128)
(AND (NEQ CODE 255)
(GREATERP CODE 160])
(STRING-CHAR-P
[LAMBDA (CHAR)
T])
(ALPHA-CHAR-P
[LAMBDA (CHAR) (* raf "23-Oct-85 15:03")
(LET ((CODE (fetch (CHARACTER CODE) of CHAR))) (* should also be true for greek alphabetics, etc.)
(OR (AND (IGEQ CODE (CHARCODE A))
(ILEQ CODE (CHARCODE Z)))
(AND (IGEQ CODE (CHARCODE a))
(ILEQ CODE (CHARCODE z)))
(AND (IGREATERP CODE 255)
(FMEMB (RSH CODE 8)
\ALPHACHARSETS)
(GRAPHIC-CHAR-P CODE])
(ALPHANUMERICP
[LAMBDA (CHAR) (* lmm "28-Oct-85 20:40")
(OR (ALPHA-CHAR-P CHAR)
(NOT (NULL (DIGIT-CHAR-P CHAR])
(CODE-CHAR
[LAMBDA (CODE BITS FONT) (* lmm "12-Jul-85 20:47")
(if (AND (OR (NULL BITS)
(EQ BITS 0))
(OR (NULL FONT)
(EQ FONT 0))
(AND (FIXP CODE)
(GEQ CODE 0)
(LESSP CODE CHAR-CODE-LIMIT)))
then (* Unique pointers for character codes)
(create CHARACTER
CODE ← CODE])
(CHAR-EQUAL
[CL:LAMBDA (CHAR &REST CHARS)
(CL:APPLY (FUNCTION CHAR=)
(CL:MAPCAR (FUNCTION CHAR-UPCASE)
(CONS CHAR CHARS])
(CHAR-FONT
[LAMBDA (CHAR)
0])
(CHAR-GREATERP
[CL:LAMBDA (CHAR &REST CHARS)
(CL:APPLY (FUNCTION CHAR>)
(CL:MAPCAR (FUNCTION CHAR-UPCASE)
(CONS CHAR CHARS])
(CHAR-LESSP
[CL:LAMBDA (CHAR &REST CHARS)
(CL:APPLY (FUNCTION CHAR<)
(CL:MAPCAR (FUNCTION CHAR-UPCASE)
(CONS CHAR CHARS])
(CHAR-BITS
[LAMBDA (CHAR)
0])
(CHAR-CODE
[LAMBDA (CHAR) (* raf "23-Oct-85 15:04")
(fetch (CHARACTER CODE)
CHAR])
(MAKE-CHAR
[LAMBDA (CHAR BITS FONT) (* lmm " 7-Jul-85 16:35")
(if (AND (OR (NULL BITS)
(EQ BITS 0))
(OR (NULL FONT)
(EQ FONT 0)))
then CHAR])
(CL:CHARACTER
[LAMBDA (OBJECT) (* lmm "18-Jul-85 21:33")
(OR (if (TYPEP OBJECT (QUOTE CHARACTER))
then OBJECT
elseif (FIXP OBJECT)
then (INT-CHAR OBJECT)
elseif (OR (STRINGP OBJECT)
(LITATOM OBJECT))
then (INT-CHAR (CHARCODE.DECODE OBJECT)))
(ERROR OBJECT "Illegal Common Lisp Character specification"])
(CHAR=
[LAMBDA N (* raf "23-Oct-85 15:04")
(for I from 2 to N always (EQ (fetch (CHARACTER CODE)
(ARG N 1))
(fetch (CHARACTER CODE)
(ARG N I])
(CHAR/=
[LAMBDA N (* raf "23-Oct-85 15:05")
(for I from 1 to N always (for J from (ADD1 I) to N
always (NEQ (fetch (CHARACTER CODE)
(ARG N I))
(fetch (CHARACTER CODE)
(ARG N J])
(CHAR<
[LAMBDA N (* raf "23-Oct-85 15:05")
(for J from 2 to N always (LESSP (fetch (CHARACTER CODE)
(ARG N (SUB1 J)))
(fetch (CHARACTER CODE)
(ARG N J])
(CHAR>
[LAMBDA N (* raf "23-Oct-85 15:05")
(for J from 2 to N always (GREATERP (fetch (CHARACTER CODE)
(ARG N (SUB1 J)))
(fetch (CHARACTER CODE)
(ARG N J])
(CHAR>=
[LAMBDA N (* raf "23-Oct-85 15:05")
(for J from 2 to N always (GEQ (fetch (CHARACTER CODE)
(ARG N (SUB1 J)))
(fetch (CHARACTER CODE)
(ARG N J])
(CHAR<=
[LAMBDA N (* raf "23-Oct-85 15:06")
(for J from 2 to N always (LEQ (fetch (CHARACTER CODE)
(ARG N (SUB1 J)))
(fetch (CHARACTER CODE)
(ARG N J])
(DIGIT-CHAR-P
[LAMBDA (CHAR RADIX) (* lmm " 7-Jul-85 17:03")
(LET ((R (OR RADIX 10))
(CODE (fetch (CHARACTER CODE)
CHAR))
VAL)
(AND (GEQ CODE (CHARCODE "0"))
(if (OR (LEQ R 10)
(LEQ CODE (CHARCODE "9")))
then (AND (LESSP (SETQ VAL (DIFFERENCE CODE (CHARCODE 0)))
R)
VAL)
else [if (GEQ CODE (CHARCODE "a"))
then (add CODE (DIFFERENCE (CHARCODE "A")
(CHARCODE "a"]
(AND (GEQ CODE (CHARCODE "A"))
(LESSP [SETQ VAL (PLUS 10 (DIFFERENCE CODE (CHARCODE "A"]
RADIX)
VAL])
(INT-CHAR
[LAMBDA (INTEGER) (* lmm " 7-Jul-85 16:50")
(CODE-CHAR INTEGER])
(UPPER-CASE-P
[LAMBDA (CHAR)
(LET ((CODE (fetch (CHARACTER CODE) of CHAR)))
(OR (AND (GEQ CODE (CHARCODE A))
(LEQ CODE (CHARCODE Z)))
(AND (GREATERP CODE 255)
(PROGN (* should know about upper-case greek)
NIL])
(LOWER-CASE-P
[LAMBDA (CHAR) (* lmm " 7-Jul-85 17:10")
(LET ((CODE (fetch (CHARACTER CODE) of CHAR)))
(OR (AND (GEQ CODE (CHARCODE a))
(LEQ CODE (CHARCODE z)))
(AND (GREATERP CODE 255)
(PROGN (* should know about upper-case greek)
NIL])
(BOTH-CASE-P
[LAMBDA (CHAR)
(OR (UPPER-CASE-P CHAR)
(LOWER-CASE-P CHAR])
(NAME-CHAR
[LAMBDA (NAME) (* lmm "28-Oct-85 20:51")
(CAR (NLSETQ (INT-CHAR (CHARCODE.DECODE NAME])
(DIGIT-CHAR
[CL:LAMBDA (WEIGHT &OPTIONAL (RADIX 10)
(FONT 0)) (* lmm "28-Oct-85 20:44")
(AND (EQ FONT 0)
(INTEGERP RADIX)
(LESSP WEIGHT RADIX)
(if (OR (LESSP WEIGHT 10)
(LEQ RADIX 10))
then (CODE-CHAR (PLUS (CHARCODE 0)
WEIGHT))
else (CODE-CHAR (PLUS (CHARCODE A)
(DIFFERENCE WEIGHT 10])
(CHAR-NAME
[LAMBDA (CHAR) (* lmm "28-Oct-85 21:28")
(LET ((CODE (fetch (CHARACTER CODE)
CHAR)))
(for X in CHARACTERNAMES when (EQ (CADR X)
CODE)
do (RETURN (CAR X])
(CHAR-NOT-EQUAL
[CL:LAMBDA (CHAR &REST CHARS)
(CL:APPLY (FUNCTION CHAR/=)
(CL:MAPCAR (FUNCTION CHAR-UPCASE)
(CONS CHAR CHARS])
(CHAR-NOT-GREATERP
[CL:LAMBDA (CHAR &REST CHARS)
(CL:APPLY (FUNCTION CHAR<=)
(CL:MAPCAR (FUNCTION CHAR-UPCASE)
(CONS CHAR CHARS])
(CHAR-NOT-LESSP
[CL:LAMBDA (CHAR &REST CHARS)
(CL:APPLY (FUNCTION CHAR>=)
(CL:MAPCAR (FUNCTION CHAR-UPCASE)
(CONS CHAR CHARS])
(CHAR-INT
[LAMBDA (CHAR)
(CHAR-CODE CHAR])
(CHAR-DOWNCASE
[LAMBDA (CHAR) (* lmm " 1-Aug-85 12:47")
(if (UPPER-CASE-P CHAR)
then [CODE-CHAR (PLUS (CHAR-CODE CHAR)
(DIFFERENCE (CHARCODE a)
(CHARCODE A]
else CHAR])
(CHAR-UPCASE
[LAMBDA (CHAR) (* lmm " 1-Aug-85 12:47")
(if (LOWER-CASE-P CHAR)
then [CODE-CHAR (PLUS (CHAR-CODE CHAR)
(DIFFERENCE (CHARCODE A)
(CHARCODE a]
else CHAR])
(CHAR-BIT
[LAMBDA (CHAR NAME) (* lmm " 7-Jul-85 17:41")
(ERROR (LIST "Bit " NAME " not supported."])
(SET-CHAR-BIT
[LAMBDA (CHAR NAME NEWVALUE) (* lmm " 7-Jul-85 17:41")
(ERROR (LIST "Bit " NAME " not supported."])
(CHARACTERP
[LAMBDA (X) (* lmm " 1-Aug-85 22:45")
(TYPENAMEP X (QUOTE CHARACTER])
)
(DEFINEQ
(CHARACTER.PRINT
[LAMBDA (CHAR) (* raf "23-Oct-85 15:07")
(CONS (CONCAT \CML.READPREFIX "\" (CHARCODE.UNDECODE (fetch (CHARACTER CODE)
of CHAR])
(CHARCODE.UNDECODE
[LAMBDA (CODE) (* raf "16-Oct-85 17:15")
(if (OR (DIGITCHARP CODE)
(ALPHACHARP CODE))
then (ALLOCSTRING 1 CODE)
else (for X in CHARACTERNAMES when (EQ (CADR X)
CODE)
do (RETURN (CAR X)) finally (RETURN (if (LEQ CODE 31)
then (CONCAT
"↑"
(CHARCODE.UNDECODE
(LOGOR CODE 64)))
else (ALLOCSTRING 1 CODE])
)
(SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER))
(NTYPX (CODE-CHAR 0 0 0)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA DIGIT-CHAR CHAR<= CHAR>= CHAR> CHAR< CHAR/= CHAR= CHAR-NOT-LESSP CHAR-NOT-GREATERP
CHAR-NOT-EQUAL CHAR-LESSP CHAR-GREATERP CHAR-EQUAL)
)
(PUTPROPS CMLCHARACTER COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2477 12039 (STANDARD-CHAR-P 2487 . 2813) (GRAPHIC-CHAR-P 2815 . 3145) (STRING-CHAR-P
3147 . 3194) (ALPHA-CHAR-P 3196 . 3761) (ALPHANUMERICP 3763 . 3957) (CODE-CHAR 3959 . 4422) (
CHAR-EQUAL 4424 . 4589) (CHAR-FONT 4591 . 4634) (CHAR-GREATERP 4636 . 4804) (CHAR-LESSP 4806 . 4971) (
CHAR-BITS 4973 . 5016) (CHAR-CODE 5018 . 5174) (MAKE-CHAR 5176 . 5425) (CL:CHARACTER 5427 . 5894) (
CHAR= 5896 . 6176) (CHAR/= 6178 . 6516) (CHAR< 6518 . 6807) (CHAR> 6809 . 7103) (CHAR>= 7105 . 7401) (
CHAR<= 7403 . 7699) (DIGIT-CHAR-P 7701 . 8446) (INT-CHAR 8448 . 8581) (UPPER-CASE-P 8583 . 8932) (
LOWER-CASE-P 8934 . 9355) (BOTH-CASE-P 9357 . 9458) (NAME-CHAR 9460 . 9632) (DIGIT-CHAR 9634 . 10093)
(CHAR-NAME 10095 . 10386) (CHAR-NOT-EQUAL 10388 . 10558) (CHAR-NOT-GREATERP 10560 . 10733) (
CHAR-NOT-LESSP 10735 . 10905) (CHAR-INT 10907 . 10967) (CHAR-DOWNCASE 10969 . 11260) (CHAR-UPCASE
11262 . 11551) (CHAR-BIT 11553 . 11716) (SET-CHAR-BIT 11718 . 11885) (CHARACTERP 11887 . 12037)) (
12040 12841 (CHARACTER.PRINT 12050 . 12288) (CHARCODE.UNDECODE 12290 . 12839)))))
STOP