(FILECREATED "25-Jul-86 23:29:47" {ERIS}<LISPCORE>LIBRARY>CMLCHARACTER.;28 25935  

      changes to:  (OPTIMIZERS OPT-CHAR-CODE OPT-CODE-CHAR)
                   (VARS CMLCHARACTERCOMS)

      previous date: " 9-Jul-86 15:46:24" {ERIS}<LISPCORE>LIBRARY>CMLCHARACTER.;27)


(* 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 "28-Oct-85 20:44")
         (AND (EQ FONT 0)
              (INTEGERP RADIX)
              (LESSP WEIGHT RADIX)
              (COND
                 ((OR (LESSP WEIGHT 10)
                      (LEQ 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 (2699 5798 (CHARCODE 2709 . 2772) (CHARCODE.DECODE 2774 . 5796)) (10059 11986 (
CL:CHARACTER 10069 . 10513) (CHAR-DOWNCASE 10515 . 10840) (CHAR-UPCASE 10842 . 11165) (DIGIT-CHAR 
11167 . 11729) (MAKE-CHAR 11731 . 11984)) (11987 16378 (CHARACTERP 11997 . 12143) (STANDARD-CHAR-P 
12145 . 12467) (GRAPHIC-CHAR-P 12469 . 13642) (STRING-CHAR-P 13644 . 13687) (ALPHA-CHAR-P 13689 . 
14345) (DIGIT-CHAR-P 14347 . 15285) (ALPHANUMERICP 15287 . 15476) (UPPER-CASE-P 15478 . 15837) (
LOWER-CASE-P 15839 . 16276) (BOTH-CASE-P 16278 . 16376)) (16379 19286 (CHAR-INT 16389 . 16445) (
INT-CHAR 16447 . 16584) (CHAR-BITS 16586 . 16625) (CHAR-FONT 16627 . 16666) (CHAR-CODE 16668 . 16827) 
(CODE-CHAR 16829 . 17291) (NAME-CHAR 17293 . 17461) (CHAR-NAME 17463 . 19284)) (19287 19619 (CHAR-BIT 
19297 . 19454) (SET-CHAR-BIT 19456 . 19617)) (19620 23040 (CHAR-EQUAL 19630 . 19805) (CHAR-GREATERP 
19807 . 19985) (CHAR-LESSP 19987 . 20162) (CHAR= 20164 . 20513) (CHAR/= 20515 . 21017) (CHAR< 21019 . 
21387) (CHAR> 21389 . 21763) (CHAR>= 21765 . 22126) (CHAR<= 22128 . 22489) (CHAR-NOT-EQUAL 22491 . 
22671) (CHAR-NOT-GREATERP 22673 . 22856) (CHAR-NOT-LESSP 22858 . 23038)) (23041 25302 (CHARACTER.READ 
23051 . 24084) (CHARACTER.PRINT 24086 . 25140) (CHARCODE.UNDECODE 25142 . 25300)))))
STOP