(FILECREATED " 1-Aug-85 23:02:41" {ERIS}<LISPCORE>LIBRARY>CMLCHARACTER.;9 10256
changes to: (VARS CMLCHARACTERCOMS) (FNS CHARACTERP CHAR-DOWNCASE CHAR-UPCASE CHARACTER.PRINT)
previous date: "18-Jul-85 21:38:58" {ERIS}<LISPCORE>LIBRARY>CMLCHARACTER.;6)
(* 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-FONT 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-INT CHAR-DOWNCASE CHAR-UPCASE CHAR-BIT
SET-CHAR-BIT CHARACTERP) (FNS CHARACTER.PRINT CHARCODE.UNDECODE) (DECLARE: DONTEVAL@LOAD
DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CHAR<= CHAR>= CHAR> CHAR< CHAR/=
CHAR=)))))
[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 " 7-Jul-85 16:11")
(FMEMB (fetch CODE of CHAR)
(CONSTANT (CHCON
"!%"#%%'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]↑←`abcdefghijklmnopqrstuvwxyz{|}~
"])
(GRAPHIC-CHAR-P
[LAMBDA (CHAR) (* lmm "16-Jul-85 16:36")
(LET [(CODE (LOGAND 255 (fetch 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) (* lmm " 7-Jul-85 16:18")
(LET ((CODE (fetch 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)
(OR (ALPHA-CHAR-P X)
(NOT (NULL (DIGIT-CHAR-P X])
(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-FONT
[LAMBDA (CHAR)
0])
(CHAR-BITS
[LAMBDA (CHAR)
0])
(CHAR-CODE
[LAMBDA (CHAR)
(fetch 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
(for I from 2 to N always (EQ (fetch CODE (ARG N 1))
(fetch CODE (ARG N I])
(CHAR/=
[LAMBDA N
(for I from 1 to N always (for J from (ADD1 I) to N always (NEQ (fetch CODE (ARG N I))
(fetch CODE (ARG N J])
(CHAR<
[LAMBDA N (* lmm " 7-Jul-85 17:16")
(for J from 2 to N always (LESSP (fetch CODE (ARG N (SUB1 J)))
(fetch CODE (ARG N J])
(CHAR>
[LAMBDA N (* lmm " 7-Jul-85 17:17")
(for J from 2 to N always (GREATERP (fetch CODE (ARG N (SUB1 J)))
(fetch CODE (ARG N J])
(CHAR>=
[LAMBDA N (* lmm " 7-Jul-85 17:17")
(for J from 2 to N always (GEQ (fetch CODE (ARG N (SUB1 J)))
(fetch CODE (ARG N J])
(CHAR<=
[LAMBDA N (* lmm " 7-Jul-85 17:17")
(for J from 2 to N always (LEQ (fetch CODE (ARG N (SUB1 J)))
(fetch 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)
(INT-CHAR (CHARCODE.DECODE NAME])
(DIGIT-CHAR
[LAMBDA (WEIGHT RADIX FONT)
(AND (OR (NULL FONT)
(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)
(CHARCODE.UNDECODE (fetch CODE CHAR])
(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) (* lmm " 1-Aug-85 12:54") (CONS (CONCAT \CML.READPREFIX "\" (CHARCODE.UNDECODE (fetch
CODE of CHAR))))))
(CHARCODE.UNDECODE
[LAMBDA (CODE) (* lmm "12-Jul-85 20:49")
(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 37Q)
then (CONCAT "↑" (CHARCODE.UNDECODE
(LOGOR CODE 100Q)))
elseif (GREATERP CODE 377Q)
then (CONCAT (CHARSET.UNDECODE (RSH CODE 10Q))
"-"
(CHARCODE.UNDECODE (LOGAND CODE
543Q)))
elseif (GREATERP CODE 177Q)
then (CONCAT "#" (CHARCODE.UNDECODE
(LOGAND CODE 177Q)))
else (ALLOCSTRING 1 CODE])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA CHAR<= CHAR>= CHAR> CHAR< CHAR/= CHAR=)
)
(PUTPROPS CMLCHARACTER COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1923 8958 (STANDARD-CHAR-P 1933 . 2219) (GRAPHIC-CHAR-P 2221 . 2535) (STRING-CHAR-P
2537 . 2580) (ALPHA-CHAR-P 2582 . 3121) (ALPHANUMERICP 3123 . 3233) (CODE-CHAR 3235 . 3697) (CHAR-FONT
3699 . 3738) (CHAR-BITS 3740 . 3779) (CHAR-CODE 3781 . 3839) (MAKE-CHAR 3841 . 4079) (CL:CHARACTER
4081 . 4537) (CHAR= 4539 . 4683) (CHAR/= 4685 . 4890) (CHAR< 4892 . 5132) (CHAR> 5134 . 5373) (CHAR>=
5375 . 5612) (CHAR<= 5614 . 5851) (DIGIT-CHAR-P 5853 . 6600) (INT-CHAR 6602 . 6735) (UPPER-CASE-P 6737
. 7072) (LOWER-CASE-P 7074 . 7483) (BOTH-CASE-P 7485 . 7580) (NAME-CHAR 7582 . 7659) (DIGIT-CHAR 7661
. 8040) (CHAR-NAME 8042 . 8123) (CHAR-INT 8125 . 8181) (CHAR-DOWNCASE 8183 . 8360) (CHAR-UPCASE 8362
. 8537) (CHAR-BIT 8539 . 8700) (SET-CHAR-BIT 8702 . 8867) (CHARACTERP 8869 . 8956)) (8959 10003 (
CHARACTER.PRINT 8969 . 9110) (CHARCODE.UNDECODE 9112 . 10001)))))
STOP