(FILECREATED "16-Oct-85 17:33:15" {ERIS}<FISCHER>LIBRARY>CMLCHARACTER.;2 7411
changes to: (FNS CHARCODE.UNDECODE)
previous date: " 1-Aug-85 23:02:41" {ERIS}<FISCHER>LIBRARY>CMLCHARACTER.;1)
(* 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) (* 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)))))))
)
(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 (1862 6671 (STANDARD-CHAR-P 1872 . 2083) (GRAPHIC-CHAR-P 2085 . 2285) (STRING-CHAR-P
2287 . 2324) (ALPHA-CHAR-P 2326 . 2679) (ALPHANUMERICP 2681 . 2768) (CODE-CHAR 2770 . 3044) (CHAR-FONT
3046 . 3079) (CHAR-BITS 3081 . 3114) (CHAR-CODE 3116 . 3165) (MAKE-CHAR 3167 . 3314) (CL:CHARACTER
3316 . 3627) (CHAR= 3629 . 3729) (CHAR/= 3731 . 3868) (CHAR< 3870 . 4007) (CHAR> 4009 . 4149) (CHAR>=
4151 . 4287) (CHAR<= 4289 . 4425) (DIGIT-CHAR-P 4427 . 4909) (INT-CHAR 4911 . 4990) (UPPER-CASE-P 4992
. 5211) (LOWER-CASE-P 5213 . 5459) (BOTH-CASE-P 5461 . 5539) (NAME-CHAR 5541 . 5606) (DIGIT-CHAR 5608
. 5875) (CHAR-NAME 5877 . 5946) (CHAR-INT 5948 . 5995) (CHAR-DOWNCASE 5997 . 6174) (CHAR-UPCASE 6176
. 6351) (CHAR-BIT 6353 . 6459) (SET-CHAR-BIT 6461 . 6580) (CHARACTERP 6582 . 6669)) (6672 7158 (
CHARACTER.PRINT 6682 . 6823) (CHARCODE.UNDECODE 6825 . 7156)))))
STOP