(FILECREATED "29-Jul-86 02:50:07" {ERIS}<LISPCORE>LIBRARY>CMLCHARACTER.;29
 25834  

      changes to:  (FNS DIGIT-CHAR)

      previous date: "25-Jul-86 23:29:47" {ERIS}<LISPCORE>LIBRARY>CMLCHARACTER.;28)


(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT CMLCHARACTERCOMS)

(RPAQQ CMLCHARACTERCOMS
 
       [(COMS (* "Interlisp CHARCODE")
              (FNS CHARCODE CHARCODE.DECODE)
              (VARS CHARACTERNAMES CHARACTERSETNAMES)
              (PROP MACRO CHARCODE SELCHARQ ALPHACHARP DIGITCHARP UCASECODE)
              (ALISTS (DWIMEQUIVLST SELCHARQ)
                     (PRETTYEQUIVLST SELCHARQ)))
        (COMS (* "Common Lisp CHARACTER type")
              (DECLARE: EVAL@COMPILE DONTCOPY (RECORDS CHARACTER))
              (INITVARS (\CODE-CHAR-HASH (HASHARRAY 512)))
              (ADDVARS (GLOBALVARS \CHARHI)
                     (\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))
              (OPTIMIZERS OPT-CHAR-CODE OPT-CODE-CHAR))
        (FNS CL:CHARACTER CHAR-DOWNCASE CHAR-UPCASE DIGIT-CHAR MAKE-CHAR)
        (FNS CHARACTERP STANDARD-CHAR-P GRAPHIC-CHAR-P STRING-CHAR-P ALPHA-CHAR-P DIGIT-CHAR-P 
             ALPHANUMERICP UPPER-CASE-P LOWER-CASE-P BOTH-CASE-P)
        (FNS CHAR-INT INT-CHAR CHAR-BITS CHAR-FONT CHAR-CODE CODE-CHAR NAME-CHAR CHAR-NAME)
        (FNS CHAR-BIT SET-CHAR-BIT)
        (FNS CHAR-EQUAL CHAR-GREATERP CHAR-LESSP CHAR= CHAR/= CHAR< CHAR> CHAR>= CHAR<= 
             CHAR-NOT-EQUAL CHAR-NOT-GREATERP CHAR-NOT-LESSP)
        (FNS CHARACTER.READ CHARACTER.PRINT CHARCODE.UNDECODE)
        [DECLARE: DONTEVAL@LOAD DOCOPY (P (SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER)
                                                            T)
                                                 (NTYPX (CODE-CHAR 0 0 0)))
                                          (DEFPRINT (QUOTE CHARACTER)
                                                 (QUOTE CHARACTER.PRINT]
        (PROP FILETYPE CMLCHARACTER)
        (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA)
                      (NLAML CHARCODE)
                      (LAMA CHAR-NOT-LESSP CHAR-NOT-GREATERP CHAR-NOT-EQUAL CHAR<= CHAR>= CHAR> CHAR< 
                            CHAR/= CHAR= CHAR-LESSP CHAR-GREATERP CHAR-EQUAL DIGIT-CHAR])



(* "Interlisp CHARCODE")


(DEFINEQ

(CHARCODE

  [NLAMBDA (CHAR)
    (CHARCODE.DECODE
 CHAR])

(CHARCODE.DECODE

  [LAMBDA (C NOERROR)
                                        (* bvm: "30-May-86 13:51")

    (DECLARE
 (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES))
    (COND
       ((NOT C)
        NIL)
       ((LISTP C)
        (CONS (CHARCODE.DECODE
 (CAR C)
                     NOERROR)
              (CHARCODE.DECODE
 (CDR C)
                     NOERROR)))
       ((NOT (OR (ATOM C)
                 (STRINGP C)))
        (AND (NOT NOERROR)
             (ERROR "BAD CHARACTER SPECIFICATION" C)))
       ((EQ (NCHARS C)
            1)
        (CHCON1 C))
       (T
        (SELECTQ (NTHCHAR C 1)
            (^ (AND (SETQ C (CHARCODE.DECODE
 (SUBSTRING C 2 -1)
                                   NOERROR))
                    (LOGAND C (LOGNOT 96))))
            (#                                               (* "We use IPLUS instead of LOGOR here because some people want ##char to read as Xerox Meta, i.e., 1,char")

               (AND (SETQ C (CHARCODE.DECODE
 (SUBSTRING C 2 -1)
                                   NOERROR))
                    (IPLUS C 128)))
            (LET
             ((STR (MKSTRING C)))
             (for
 X in
 CHARACTERNAMES when
 (STRING.EQUAL (CAR X)
                                                  STR) do
 (RETURN (OR (NUMBERP (CADR X))
                                                                      (CHARCODE.DECODE
 (CADR X)
                                                                             NOERROR)))
                finally

                (RETURN
                 (LET ((POS (STRPOSL (QUOTE (%, - "." "|"))
                                   STR)))                    (* In the form charset,char)

                      (COND
                         ([AND POS (PROGN (PSETQ POS (SUBATOM STR 1 (SUB1 POS))
                                                 STR
                                                 (SUBATOM STR (ADD1 POS)
                                                        -1))
                                          (SETQ STR (COND
                                                       ((FIXP STR)
                                                        (PACK* STR (QUOTE Q)))
                                                       (T (CHARCODE.DECODE
 STR NOERROR]
                          (LOGOR STR (LLSH [COND
                                              ((FIXP POS)
                                               (PACK* POS (QUOTE Q)))
                                              (T (OR (CADR (find
 PAIR in
 CHARACTERSETNAMES
                                                              suchthat
 (STRING-EQUAL (CAR PAIR)
                                                                              POS)))
                                                     (ERROR "BAD CHARACTERSET SPECIFICATION" C]
                                           8)))
                         ((NOT NOERROR)
                          (ERROR "BAD CHARACTER SPECIFICATION" C])
)

(RPAQQ CHARACTERNAMES
 (("Page" 12)
                       ("Form" 12)
                       ("FF" 12)
                       ("Rubout" 127)
                       ("Del" 127)
                       ("Null" 0)
                       ("Escape" 27)
                       ("Esc" 27)
                       ("Bell" 7)
                       ("Tab" 9)
                       ("Backspace" 8)
                       ("Bs" 8)
                       ("Newline" 13)
                       ("CR" 13)
                       ("EOL" 13)
                       ("Tenexeol" 31)
                       ("Space" 32)
                       ("Sp" 32)
                       ("Linefeed" 10)
                       ("LF" 10)
                       ("Return" 13)))

(RPAQQ CHARACTERSETNAMES
 (("Greek" 38)
                          ("Cyrillic" 39)
                          ("Hira" 36)
                          ("Hiragana" 36)
                          ("Kata" 37)
                          ("Katakana" 37)
                          ("Kanji" 48)))

(PUTPROPS CHARCODE MACRO
 (DEFMACRO (C
 ) (KWOTE (CHARCODE.DECODE C T)) )
)

(PUTPROPS SELCHARQ MACRO
 [F (CONS (QUOTE SELECTQ)
                                  (CONS (CAR F)
                                        (MAPLIST (CDR F)
                                               (FUNCTION (LAMBDA (I)
                                                           (COND
                                                              ((CDR I)
                                                               (CONS (CHARCODE.DECODE (CAAR I))
                                                                     (CDAR I)))
                                                              (T (CAR I])

(PUTPROPS ALPHACHARP MACRO
 ((CHAR)
                            ([LAMBDA (UCHAR)
                               (DECLARE
 (LOCALVARS UCHAR))
                               (AND (IGEQ UCHAR (CHARCODE A))
                                    (ILEQ UCHAR (CHARCODE Z]
                             (LOGAND CHAR 95))))

(PUTPROPS DIGITCHARP MACRO
 [LAMBDA (CHAR)
                             (AND (IGEQ CHAR (CHARCODE 0))
                                  (ILEQ CHAR (CHARCODE 9])

(PUTPROPS UCASECODE MACRO
 (OPENLAMBDA (CHAR)
                                 (COND
                                    ((AND (IGEQ CHAR (CHARCODE a))
                                          (ILEQ CHAR (CHARCODE z)))
                                     (LOGAND CHAR 95))
                                    (T CHAR))))

(ADDTOVAR DWIMEQUIVLST
 (SELCHARQ . SELECTQ))

(ADDTOVAR PRETTYEQUIVLST
 (SELCHARQ . SELECTQ))



(* "Common Lisp CHARACTER type")


(DECLARE: EVAL@COMPILE DONTCOPY 
[DECLARE: EVAL@COMPILE 

(ACCESSFNS CHARACTER
 [(CODE (\LOLOC (\DTEST DATUM (QUOTE CHARACTER]
                     (CREATE
 (\VAG2 \CHARHI CODE)))
]
)

(RPAQ? \CODE-CHAR-HASH
 (HASHARRAY 512))

(ADDTOVAR GLOBALVARS
 \CHARHI)

(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))
)
(DEFOPTIMIZER CHAR-CODE
 OPT-CHAR-CODE (CHAR)
                              (BQUOTE (\LOLOC (\DTEST (\, CHAR)
                                                     (QUOTE CHARACTER)))))

(DEFOPTIMIZER CODE-CHAR
 OPT-CODE-CHAR (CODE &OPTIONAL BITS FONT)
                              (COND
                                 ((AND (NULL BITS)
                                       (NULL FONT)
                                       (BQUOTE ((LAMBDA (C)
                                                  (DECLARE
 (LOCALVARS C))
                                                  (AND (LEQ C (SUB1 CHAR-CODE-LIMIT))
                                                       (\VAG2 \CHARHI C)))
                                                (\, CODE)))))
                                 (T (QUOTE COMPILER:PASS))))

(DEFINEQ

(CL:CHARACTER

  [LAMBDA (OBJECT)
                                           (* lmm "18-Jul-85 21:33")

    (OR [COND
           ((TYPEP OBJECT (QUOTE CHARACTER))
            OBJECT)
           ((FIXP OBJECT)
            (INT-CHAR
 OBJECT))
           ((OR (STRINGP OBJECT)
                (LITATOM OBJECT))
            (INT-CHAR
 (CHARCODE.DECODE
 OBJECT]
        (ERROR OBJECT "Illegal Common Lisp Character specification"])

(CHAR-DOWNCASE

  [LAMBDA (CHAR)
                                             (* lmm " 1-Aug-85 12:47")

    (COND
       [(UPPER-CASE-P
 CHAR)
        (CODE-CHAR
 (PLUS (CHAR-CODE
 CHAR)
                         (DIFFERENCE (CHARCODE
 a)
                                (CHARCODE
 A]
       (T CHAR])

(CHAR-UPCASE

  [LAMBDA (CHAR)
                                             (* lmm " 1-Aug-85 12:47")

    (COND
       [(LOWER-CASE-P
 CHAR)
        (CODE-CHAR
 (PLUS (CHAR-CODE
 CHAR)
                         (DIFFERENCE (CHARCODE
 A)
                                (CHARCODE
 a]
       (T CHAR])

(DIGIT-CHAR

  [CL:LAMBDA (WEIGHT &OPTIONAL (RADIX 10)
                    (FONT 0))
                                (* lmm "29-Jul-86 02:49")

         (AND (EQ FONT 0)
              (< -1 WEIGHT RADIX 37)
              (COND
                 ((OR (< WEIGHT 10)
                      (<= RADIX 10))
                  (CODE-CHAR
 (PLUS (CHARCODE
 0)
                                   WEIGHT)))
                 (T (CODE-CHAR
 (PLUS (CHARCODE
 A)
                                     (DIFFERENCE WEIGHT 10])

(MAKE-CHAR

  [LAMBDA (CHAR BITS FONT)
                                   (* lmm " 7-Jul-85 16:35")

    (COND
       ((AND (OR (NULL BITS)
                 (EQ BITS 0))
             (OR (NULL FONT)
                 (EQ FONT 0)))
        CHAR])
)
(DEFINEQ

(CHARACTERP

  [LAMBDA (X)
                                                (* lmm " 1-Aug-85 22:45")

    (TYPENAMEP X (QUOTE CHARACTER])

(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)
                                             (* bvm: "14-May-86 16:19")

          
          (* * True if CHAR represents a graphic (printing) character.

          Definition follows NS character standard)


    (LET* ((CODE (fetch
 (CHARACTER CODE) of
 CHAR))
           (CSET (LRSH CODE 8)))
          (AND [PROGN                                        (* 

                                               "Graphic charsets are zero, 41 thru 176, 241 thru 276")

                      (OR (EQ CSET 0)
                          (AND (IGREATERP (SETQ CSET (LOGAND CSET 127))
                                      32)
                               (NEQ CSET 127]
               (PROGN                                        (* 

                          "Printing chars within a character set are SPACE thru 176 and 241 thru 276")

                      (OR (EQ (SETQ CODE (LOGAND CODE 255))
                              (CHARCODE
 SPACE))
                          (AND (IGREATERP (SETQ CODE (LOGAND CODE 127))
                                      32)
                               (NEQ CODE 127])

(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])

(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"))
              (COND
                 ((OR (LEQ R 10)
                      (LEQ CODE (CHARCODE
 "9")))
                  (AND (LESSP (SETQ VAL (DIFFERENCE CODE (CHARCODE
 0)))
                              R)
                       VAL))
                 (T [COND
                       ((GEQ CODE (CHARCODE
 "a"))
                        (add
 CODE (DIFFERENCE (CHARCODE
 "A")
                                         (CHARCODE
 "a"]
                    (AND (GEQ CODE (CHARCODE
 "A"))
                         (LESSP [SETQ VAL (PLUS 10 (DIFFERENCE CODE (CHARCODE
 "A"]
                                RADIX)
                         VAL])

(ALPHANUMERICP

  [LAMBDA (CHAR)
                                             (* lmm "28-Oct-85 20:40")

    (OR (ALPHA-CHAR-P
 CHAR)
        (NOT (NULL (DIGIT-CHAR-P
 CHAR])

(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])
)
(DEFINEQ

(CHAR-INT

  [LAMBDA (CHAR)
    (CHAR-CODE
 CHAR])

(INT-CHAR

  [LAMBDA (INTEGER)
                                          (* lmm " 7-Jul-85 16:50")

    (CODE-CHAR
 INTEGER])

(CHAR-BITS

  [LAMBDA (CHAR)
    0])

(CHAR-FONT

  [LAMBDA (CHAR)
    0])

(CHAR-CODE

  [LAMBDA (CHAR)
                                             (* raf "23-Oct-85 15:04")

    (fetch
 (CHARACTER CODE)
           CHAR])

(CODE-CHAR

  [LAMBDA (CODE BITS FONT)
                                   (* lmm "12-Jul-85 20:47")

    (COND
       ((AND (OR (NULL BITS)
                 (EQ BITS 0))
             (OR (NULL FONT)
                 (EQ FONT 0))
             (AND (FIXP CODE)
                  (GEQ CODE 0)
                  (LESSP CODE CHAR-CODE-LIMIT)))             (* Unique pointers for character codes)

        (create
 CHARACTER
               CODE _ CODE])

(NAME-CHAR

  [LAMBDA (NAME)
                                             (* lmm "28-Oct-85 20:51")

    (CAR (NLSETQ (INT-CHAR
 (CHARCODE.DECODE
 NAME])

(CHAR-NAME

  [LAMBDA (CHAR)
                                             (* bvm: "14-May-86 16:19")

    (LET ((CODE (fetch
 (CHARACTER CODE)
                       CHAR)))
         (COND
            [(for
 X in
 CHARACTERNAMES when
 (EQ (CADR X)
                                               CODE) do
 (RETURN (CAR X]
            ((NOT (GRAPHIC-CHAR-P
 CHAR))                     (* All non-graphics must have a name, 

                                                             so invent one)

             (LET ((CSET (LRSH CODE 8)))
                  (SETQ CODE (LOGAND CODE 255))
                  (COND
                     [(EQ CSET 0)
                      (COND
                         [(ILEQ CODE (CHARCODE
 ^Z))          (* Control chars)

                          (CONCAT "^" (ALLOCSTRING 1 (LOGOR CODE (CHARCODE
 @]
                         (T (CONCAT "0," (OCTALSTRING CODE]
                     (T                                      (* Build extended cset name.

                                                             Separate components with hyphen, 

                                                             rather than comma, so that it can be 

                                                             read back in properly)

                        (CONCAT (for
 X in
 CHARACTERSETNAMES when
 (EQ (CADR X)
                                                                     CSET)
                                   do
 (RETURN (CAR X)) finally
 
                                                             (* No name, use octal)

                                                             (RETURN (OCTALSTRING CSET)))
                               "-"
                               (OCTALSTRING CODE])
)
(DEFINEQ

(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."])
)
(DEFINEQ

(CHAR-EQUAL

  [CL:LAMBDA (CHAR &REST CHARS)
         (CL:APPLY (FUNCTION CHAR=)
                (CL:MAPCAR (FUNCTION CHAR-UPCASE)
                       (CONS CHAR CHARS])

(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=

  [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])

(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])
)
(DEFINEQ

(CHARACTER.READ

  [LAMBDA (STREAM)
                                           (* bvm: "14-May-86 15:28")

          
          (* * Called by the #\ macro -- reads a character object consisting of the thing 

          next named)


    (INT-CHAR
 (LET ((NEXTCHAR (READCCODE STREAM)))
                   (COND
                      ((fetch
 STOPATOM of
 (\SYNCODE (fetch
 READSA of
 (\GTREADTABLE))
                                                 (PEEKCCODE STREAM)))
                                                             (* Terminates next, so it's just this 

                                                             char)

                       NEXTCHAR)
                      (T                                     (* Read a whole name, up to the next 

                                                             break/sepr)

                         (CHARCODE.DECODE
 (CONCAT (ALLOCSTRING 1 NEXTCHAR)
                                                 (RSTRING STREAM])

(CHARACTER.PRINT

  [LAMBDA (CHAR STREAM)
                                      (* bvm: "14-May-86 14:05")

    (LET* ((N (fetch
 (CHARACTER CODE) of
 CHAR))
           (PNAME (CHAR-NAME
 CHAR)))
          [.SPACECHECK. STREAM (IPLUS 2 (COND
                                           (PNAME (NCHARS PNAME))
                                           (T 1]             (* Print as "#\" followed by character 

                                                             name)

          (\OUTCHAR STREAM (fetch
 (READTABLEP HASHMACROCHAR) of
 *READTABLE*))
          (\OUTCHAR STREAM (CHARCODE
 \))
          (COND
             [PNAME (COND
                       ((STRINGP PNAME)
                        (\SOUT PNAME STREAM))
                       (T (LET (*PRINT-ESCAPE*)
                               (\PRINDATUM PNAME STREAM]
             (T (\OUTCHAR STREAM N)))                        (* Return T to say we printed it 

                                                             ourselves)

          T])

(CHARCODE.UNDECODE

  [LAMBDA (CODE)
                                             (* bvm: "14-May-86 14:06")

    (CHAR-NAME
 (INT-CHAR
 CODE])
)
(DECLARE: DONTEVAL@LOAD DOCOPY 
(SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER)
                  T)
       (NTYPX (CODE-CHAR 0 0 0)))
(DEFPRINT (QUOTE CHARACTER)
       (QUOTE CHARACTER.PRINT))
)

(PUTPROPS CMLCHARACTER FILETYPE
 COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 CHARCODE)

(ADDTOVAR LAMA
 CHAR-NOT-LESSP CHAR-NOT-GREATERP CHAR-NOT-EQUAL CHAR<= CHAR>= CHAR> CHAR< CHAR/= CHAR= 
                     CHAR-LESSP CHAR-GREATERP CHAR-EQUAL DIGIT-CHAR)
)
(PUTPROPS CMLCHARACTER COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2632 5731 (CHARCODE 2642 . 2705) (CHARCODE.DECODE 2707 . 5729)) (9992 11885 (
CL:CHARACTER 10002 . 10446) (CHAR-DOWNCASE 10448 . 10773) (CHAR-UPCASE 10775 . 11098) (DIGIT-CHAR 
11100 . 11628) (MAKE-CHAR 11630 . 11883)) (11886 16277 (CHARACTERP 11896 . 12042) (STANDARD-CHAR-P 
12044 . 12366) (GRAPHIC-CHAR-P 12368 . 13541) (STRING-CHAR-P 13543 . 13586) (ALPHA-CHAR-P 13588 . 
14244) (DIGIT-CHAR-P 14246 . 15184) (ALPHANUMERICP 15186 . 15375) (UPPER-CASE-P 15377 . 15736) (
LOWER-CASE-P 15738 . 16175) (BOTH-CASE-P 16177 . 16275)) (16278 19185 (CHAR-INT 16288 . 16344) (
INT-CHAR 16346 . 16483) (CHAR-BITS 16485 . 16524) (CHAR-FONT 16526 . 16565) (CHAR-CODE 16567 . 16726) 
(CODE-CHAR 16728 . 17190) (NAME-CHAR 17192 . 17360) (CHAR-NAME 17362 . 19183)) (19186 19518 (CHAR-BIT 
19196 . 19353) (SET-CHAR-BIT 19355 . 19516)) (19519 22939 (CHAR-EQUAL 19529 . 19704) (CHAR-GREATERP 
19706 . 19884) (CHAR-LESSP 19886 . 20061) (CHAR= 20063 . 20412) (CHAR/= 20414 . 20916) (CHAR< 20918 . 
21286) (CHAR> 21288 . 21662) (CHAR>= 21664 . 22025) (CHAR<= 22027 . 22388) (CHAR-NOT-EQUAL 22390 . 
22570) (CHAR-NOT-GREATERP 22572 . 22755) (CHAR-NOT-LESSP 22757 . 22937)) (22940 25201 (CHARACTER.READ 
22950 . 23983) (CHARACTER.PRINT 23985 . 25039) (CHARCODE.UNDECODE 25041 . 25199)))))
STOP