(FILECREATED "29-Aug-86 16:09:53" {ERIS}<LISPCORE>LIBRARY>CMLCHARACTER.;32
 38691  

      changes to:  (VARS CMLCHARACTERCOMS CHARACTERNAMES)
                   (FNS NAME-CHAR* NAME-CHAR CHAR-NAME CHARACTER.PRINT CHAR-BIT SET-CHAR-BIT 
                        CHAR-NAME* CHARACTER.PRINT* CHARCODE.UNDECODE CHAR-CODE CHAR-FONT CHAR-BITS 
                        CHAR-UPCASE CHAR-DOWNCASE CHAR= CHAR/= CHAR< CHAR> CHAR<= CHAR>= CHAR-EQUAL 
                        CHAR-NOT-EQUAL %%CHAR-DOWNCASE-CODE %%CHAR-UPCASE-CODE CHAR-LESSP 
                        CHAR-GREATERP CHAR-NOT-GREATERP CHAR-NOT-LESSP)
                   (VARIABLES CHAR-HYPER-BIT CHAR-SUPER-BIT CHAR-META-BIT CHAR-CONTROL-BIT 
                          CHAR-BITS-LIMIT CHAR-FONT-LIMIT CHAR-CODE-LIMIT)
                   (FUNCTIONS CODE-CHAR MAKE-CHAR %%CODE-CHAR DIGIT-CHAR DIGIT-CHAR-P 
                          %%CHAR-DOWNCASE-CODE %%CHAR-UPCASE-CODE)
                   (OPTIMIZERS MAKE-CHAR OPT-CODE-CHAR CHAR-UPCASE CHAR-DOWNCASE OPT-CHAR-CODE 
                          CHAR-CODE CODE-CHAR INT-CHAR CHAR-INT LOWER-CASE-P CHAR= CHAR/= CHAR< CHAR> 
                          CHAR<= CHAR>= CHAR-EQUAL CHAR-NOT-EQUAL %%CHAR-UPCASE-CODE 
                          %%CHAR-DOWNCASE-CODE CHAR-GREATERP CHAR-LESSP CHAR-NOT-LESSP 
                          CHAR-NOT-GREATERP)
                   (RECORDS CHARACTER)

      previous date: "26-Aug-86 15:38:59" {ERIS}<LISPCORE>LIBRARY>CMLCHARACTER.;31)


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

(PRETTYCOMPRINT CMLCHARACTERCOMS)

(RPAQQ CMLCHARACTERCOMS
 
       ((COMS (* "Interlisp CHARCODE")
              (FNS CHARCODE CHARCODE.DECODE CHARCODE.UNDECODE)
              (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))
              (ADDVARS (GLOBALVARS \CHARHI))
              (VARIABLES CHAR-BITS-LIMIT CHAR-CODE-LIMIT CHAR-CONTROL-BIT CHAR-FONT-LIMIT 
                     CHAR-HYPER-BIT CHAR-META-BIT CHAR-SUPER-BIT))
        (* * "Basic character fns")
        (FNS CHAR-CODE CHAR-INT INT-CHAR)
        (FUNCTIONS CODE-CHAR)
        (OPTIMIZERS CHAR-CODE CHAR-INT CODE-CHAR INT-CHAR)
        (* * "I/O -- Needs to be first so the rest can be read in")
        (FNS CHARACTER.READ CHARACTER.PRINT)
        (DECLARE: DONTEVAL@LOAD DOCOPY (P (SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER)
                                                            T)
                                                 (NTYPX (CODE-CHAR 0 0 0)))
                                          (DEFPRINT (QUOTE CHARACTER)
                                                 (QUOTE CHARACTER.PRINT))))
        (* * "Common lisp character functions")
        (FNS CHAR-BIT CHAR-BITS CHAR-DOWNCASE CHAR-FONT CHAR-NAME CHAR-UPCASE CL:CHARACTER NAME-CHAR 
             SET-CHAR-BIT)
        (FUNCTIONS DIGIT-CHAR MAKE-CHAR)
        (OPTIMIZERS CHAR-UPCASE CHAR-DOWNCASE MAKE-CHAR)
        (* * "Predicates")
        (FNS ALPHA-CHAR-P ALPHANUMERICP BOTH-CASE-P CHARACTERP GRAPHIC-CHAR-P LOWER-CASE-P 
             STANDARD-CHAR-P STRING-CHAR-P UPPER-CASE-P)
        (FNS CHAR-EQUAL CHAR-GREATERP CHAR-LESSP CHAR-NOT-EQUAL CHAR-NOT-GREATERP CHAR-NOT-LESSP 
             CHAR/= CHAR< CHAR<= CHAR= CHAR> CHAR>=)
        (FUNCTIONS DIGIT-CHAR-P)
        (OPTIMIZERS CHAR-EQUAL CHAR-GREATERP CHAR-LESSP CHAR-NOT-EQUAL CHAR-NOT-GREATERP 
               CHAR-NOT-LESSP CHAR/= CHAR< CHAR<= CHAR= CHAR> CHAR>= CHARACTERP LOWER-CASE-P 
               STRING-CHAR-P UPPER-CASE-P)
        (* * "Internals")
        (FUNCTIONS %%CHAR-DOWNCASE-CODE %%CHAR-UPCASE-CODE %%CODE-CHAR)
        (* * "Compiler options")
        (PROP FILETYPE CMLCHARACTER)
        (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
        (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA)
                      (NLAML CHARCODE)
                      (LAMA CHAR>= CHAR> CHAR= CHAR<= CHAR< CHAR/= CHAR-NOT-LESSP CHAR-NOT-GREATERP 
                            CHAR-NOT-EQUAL CHAR-LESSP CHAR-GREATERP CHAR-EQUAL)))))



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

(CHARCODE.UNDECODE

  (LAMBDA (CODE)
                                             (* jop: "26-Aug-86 14:27")

    (LET ((NAME (CHAR-NAME
 (CODE-CHAR CODE))))
         (AND NAME (MKSTRING NAME)))))
)

(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)
                       ("Return" 13)
                       ("Tenexeol" 31)
                       ("Space" 32)
                       ("Sp" 32)
                       ("Linefeed" 10)
                       ("LF" 10)))

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

(ADDTOVAR GLOBALVARS
 \CHARHI)
(DEFCONSTANT CHAR-BITS-LIMIT
 1)

(DEFCONSTANT CHAR-CODE-LIMIT
 65536)

(DEFCONSTANT CHAR-CONTROL-BIT
 0)

(DEFCONSTANT CHAR-FONT-LIMIT
 1)

(DEFCONSTANT CHAR-HYPER-BIT
 0)

(DEFCONSTANT CHAR-META-BIT
 0)

(DEFCONSTANT CHAR-SUPER-BIT
 0)

(* * "Basic character fns")


(DEFINEQ

(CHAR-CODE

  (LAMBDA (CHAR)
                                             (* jop: "25-Aug-86 17:30")

    (\LOLOC (\DTEST CHAR (QUOTE CHARACTER)))))

(CHAR-INT

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

(INT-CHAR

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

    (CODE-CHAR
 INTEGER])
)
(DEFUN CODE-CHAR
 (CODE &OPTIONAL (BITS 0)
                       (FONT 0)) (CL:IF (AND (EQL BITS 0)
                                             (EQL FONT 0)
                                             (< -1 CODE CHAR-CODE-LIMIT))
                                        (%%CODE-CHAR CODE)))

(DEFOPTIMIZER CHAR-CODE
 (CHAR) (BQUOTE (\LOLOC (\DTEST (\, CHAR)
                                                      (QUOTE CHARACTER)))))

(DEFOPTIMIZER CHAR-INT
 (CHAR) (BQUOTE (CHAR-CODE (\, CHAR))))

(DEFOPTIMIZER CODE-CHAR
 (CODE &OPTIONAL BITS FONT) (COND
                                                      ((AND (OR (NULL BITS)
                                                                (EQL BITS 0))
                                                            (OR (NULL FONT)
                                                                (EQL FONT 0))
                                                            (BQUOTE (LET ((%%CODE (\, CODE)))
                                                                         (AND (< -1 %%CODE 
                                                                               CHAR-CODE-LIMIT)
                                                                              (%%CODE-CHAR %%CODE))))
                                                            ))
                                                      (T (QUOTE COMPILER:PASS))))

(DEFOPTIMIZER INT-CHAR
 (INTEGER) (BQUOTE (CODE-CHAR (\, INTEGER))))

(* * "I/O -- Needs to be first so the rest can be read in")


(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)
                                      (* jop: "26-Aug-86 14:16")

    (LET ((PNAME (CHAR-NAME
 CHAR)))
         (.SPACECHECK. STREAM (+ 2 (CL:IF PNAME (CL:LENGTH PNAME)
                                          1)))               (* 

                                                             "Print as #\ followed by charcter name")

         (\OUTCHAR STREAM (fetch
 (READTABLEP HASHMACROCHAR) of
 *READTABLE*))
         (\OUTCHAR STREAM (CONSTANT (CHAR-CODE
 |\\)))
         (CL:IF PNAME (WRITE-STRING PNAME STREAM)
                (\OUTCHAR STREAM (CHAR-CODE
 CHAR)))
         T)))
)
(DECLARE: DONTEVAL@LOAD DOCOPY 
(SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER)
                  T)
       (NTYPX (CODE-CHAR 0 0 0)))
(DEFPRINT (QUOTE CHARACTER)
       (QUOTE CHARACTER.PRINT))
)
(* * "Common lisp character functions")


(DEFINEQ

(CHAR-BIT

  (LAMBDA (CHAR NAME)
                                        (* jop: "26-Aug-86 15:01")

    (CL:ERROR "Bit ~A not supported" NAME)))

(CHAR-BITS

  (LAMBDA (CHAR)
                                             (* jop: "25-Aug-86 17:35")

    (AND (CHARACTERP
 CHAR)
         0)))

(CHAR-DOWNCASE

  (LAMBDA (CHAR)
                                             (* jop: "25-Aug-86 18:01")

    (%%CODE-CHAR (%%CHAR-DOWNCASE-CODE (CHAR-CODE
 CHAR)))))

(CHAR-FONT

  (LAMBDA (CHAR)
                                             (* jop: "25-Aug-86 17:35")

    (AND (CHARACTERP
 CHAR)
         0)))

(CHAR-NAME

  (LAMBDA (CHAR)
                                             (* jop: "26-Aug-86 12:14")

    (DECLARE
 (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES))
    (CL:WHEN (OR (EQ CHAR |\Space)
                 (NOT (GRAPHIC-CHAR-P
 CHAR)))
           (LET ((CODE (CHAR-CODE
 CHAR)))
                (OR (DOLIST (X CHARACTERNAMES)
                           (CL:IF (EQ (CADR X)
                                      CODE)
                                  (RETURN (CAR X))))
                    (LET ((CSET (LRSH CODE 8)))
                         (SETQ CODE (LOGAND CODE 255))
                         (CL:IF (AND (EQL CSET 0)
                                     (<= CODE (CONSTANT (CHAR-CODE
 |\^Z))))
                                (FORMAT NIL "^~C" (CODE-CHAR (LOGOR CODE (CONSTANT (CHAR-CODE
 |\@))))
                                       )
                                (FORMAT NIL "~A-~O" (DOLIST (X CHARACTERSETNAMES
                                                               (FORMAT NIL "~O" CSET))
                                                           (CL:IF (EQ (CADR X)
                                                                      CSET)
                                                                  (RETURN (CAR X))))
                                       CODE))))))))

(CHAR-UPCASE

  (LAMBDA (CHAR)
                                             (* jop: "25-Aug-86 18:01")

    (%%CODE-CHAR (%%CHAR-UPCASE-CODE (CHAR-CODE
 CHAR)))))

(CL:CHARACTER

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

    (COND
       ((TYPEP OBJECT (QUOTE CL:CHARACTER))
        OBJECT)
       ((TYPEP OBJECT (QUOTE FIXNUM))
        (INT-CHAR
 OBJECT))
       ([AND (OR (TYPEP OBJECT (QUOTE STRING))
                 (TYPEP OBJECT (QUOTE SYMBOL)))
             (EQL 1 (CL:LENGTH (SETQ OBJECT (STRING OBJECT]
        (CHAR OBJECT 0))
       (T (CL:ERROR "Object cannot be coerced to a character: ~S" OBJECT])

(NAME-CHAR

  (LAMBDA (NAME)
                                             (* jop: "26-Aug-86 14:43")

    (SETQ NAME (STRING NAME))
    (AND
     (> (CL:LENGTH NAME)
        1)
     (CL:IF
      (EQL (CHAR NAME 0)
           |\^)
      (PROGN                                                 (* "A control character")

             (LET ((CHAR (CHAR-UPCASE
 (CHAR NAME 1))))
                  (CL:IF (AND (ALPHA-CHAR-P
 CHAR)
                              (EQL 2 (CL:LENGTH NAME)))
                         (CODE-CHAR (LOGAND (CHAR-CODE
 CHAR)
                                           63)))))
      (PROGN                                                 (* "In the form CSET-CHAR")

       (OR (PROGN                                            (* "One of the common names")

                  (DOLIST (X CHARACTERNAMES)
                         (CL:IF (STRING-EQUAL NAME (CAR X))
                                (RETURN (CODE-CHAR (CADR X))))))
           (LET* ((POS (POSITION-IF (FUNCTION (CL:LAMBDA (X)
                                                     (CL:MEMBER X (BQUOTE (|\- |\,)))))
                              NAME))
                  (CSET (AND POS (LET ((CSETNAME (SUBSEQ NAME 0 POS)))
                                      (OR (DOLIST (X CHARACTERSETNAMES)
                                                 (CL:IF (STRING-EQUAL CSETNAME (CAR X))
                                                        (RETURN (CADR X))))
                                          (PROGN             (* 

                                                            "Read in the csetname as an octal string")

                                                 (CL:DO ((I 0 (1+ I))
                                                         (N 0)
                                                         (LASTINDEX (CL:LENGTH CSETNAME)))
                                                        ((EQL I LASTINDEX)
                                                         N)
                                                        (+ (LLSH N 3)
                                                           (OR (DIGIT-CHAR-P (CHAR CSETNAME I)
                                                                      8)
                                                               (RETURN NIL)))))))))
                  (CODE (AND POS (LET ((CODENAME (SUBSEQ NAME (1+ POS))))
                                      (PROGN                 (* 

                                                            "Read in the codename as an octal string")

                                             (CL:DO ((I 0 (1+ I))
                                                     (N 0)
                                                     (LASTINDEX (CL:LENGTH CODENAME)))
                                                    ((EQL I LASTINDEX)
                                                     N)
                                                    (+ (LLSH N 3)
                                                       (OR (DIGIT-CHAR-P (CHAR CODENAME I)
                                                                  8)
                                                           (RETURN NIL)))))))))
                 (AND CSET (< CSET 256)
                      CODE
                      (< CODE 256)
                      (CODE-CHAR (+ (LLSH CSET 8)
                                    CODE))))))))))

(SET-CHAR-BIT

  (LAMBDA (CHAR NAME NEWVALUE)
                               (* jop: "26-Aug-86 15:02")

    (CL:ERROR "Bit ~A not supported" NAME)))
)
(DEFUN DIGIT-CHAR
 (WEIGHT &OPTIONAL (RADIX 10)
                         (FONT 0)) (AND (EQ FONT 0)
                                        (< -1 WEIGHT RADIX 37)
                                        (CL:IF (< WEIGHT 10)
                                               (%%CODE-CHAR (+ (CONSTANT (CHAR-CODE |\0))
                                                               WEIGHT))
                                               (%%CODE-CHAR (+ (CONSTANT (CHAR-CODE |\A))
                                                               (- WEIGHT 10))))))

(DEFUN MAKE-CHAR
 (CHAR &OPTIONAL (BITS 0)
                       (FONT 0)) (CL:IF (AND (EQL BITS 0)
                                             (EQL FONT 0))
                                        CHAR))

(DEFOPTIMIZER CHAR-UPCASE
 (CHAR) (BQUOTE (%%CODE-CHAR (%%CHAR-UPCASE-CODE (CHAR-CODE (\, CHAR))))))

(DEFOPTIMIZER CHAR-DOWNCASE
 (CHAR) (BQUOTE (%%CODE-CHAR (%%CHAR-DOWNCASE-CODE (CHAR-CODE (\, CHAR))))
                                          ))

(DEFOPTIMIZER MAKE-CHAR
 (CHAR &OPTIONAL BITS FONT) (CL:IF (AND (OR (NULL BITS)
                                                                   (EQL BITS 0))
                                                               (OR (NULL FONT)
                                                                   (EQL FONT 0)))
                                                          CHAR
                                                          (QUOTE COMPILER:PASS)))

(* * "Predicates")


(DEFINEQ

(ALPHA-CHAR-P

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

    (LET ((CODE (CHAR-CODE
 CHAR)))                           (* 

                                             "Might want to make this true for Greek char sets, etc.")

         (OR (<= (CONSTANT (CHAR-CODE
 |\A))
              CODE
              (CONSTANT (CHAR-CODE
 |\Z)))
             (<= (CONSTANT (CHAR-CODE
 |\a))
              CODE
              (CONSTANT (CHAR-CODE
 |\z)))))))

(ALPHANUMERICP

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

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

(BOTH-CASE-P

  [LAMBDA (CHAR)
    (OR (UPPER-CASE-P
 CHAR)
        (LOWER-CASE-P
 CHAR])

(CHARACTERP

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

    (TYPENAMEP OBJECT (QUOTE CHARACTER))))

(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 (CHAR-CODE
 CHAR))
           (CSET (LRSH CODE 8)))
          (AND (PROGN                                        (* 

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

                      (OR (EQ CSET 0)
                          (AND (> (SETQ CSET (LOGAND CSET 127))
                                  32)
                               (NOT (EQ CSET 127)))))
               (PROGN                                        (* 

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

                      (OR (EQ (SETQ CODE (LOGAND CODE 255))
                              (CONSTANT (CHAR-CODE
 |\Space)))
                          (AND (> (SETQ CODE (LOGAND CODE 127))
                                  32)
                               (NOT (EQ CODE 127)))))))))

(LOWER-CASE-P

  (LAMBDA (CHAR)
    (<= (CONSTANT (CHAR-CODE
 |\a))
     (CHAR-CODE
 CHAR)
     (CONSTANT (CHAR-CODE
 |\z)))))

(STANDARD-CHAR-P

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

    (AND (CL:MEMBER CHAR
                (QUOTE (|\! |\" |\# |\% |\' |\( |\) |\* |\+ |\, |\- |\. |\/ |\0 |\1 |\2 |\3 |\4 |\5 
                            |\6 |\7 |\8 |\9 |\: |\; |\< |\= |\> |\? |\@ |\A |\B |\C |\D |\E |\F |\G 
                            |\H |\I |\J |\K |\L |\M |\N |\O |\P |\Q |\R |\S |\T |\U |\V |\W |\X |\Y 
                            |\Z |\[ |\\ |\] |\^ |\_ |\` |\a |\b |\c |\d |\e |\f |\g |\h |\i |\j |\k 
                            |\l |\m |\n |\o |\p |\q |\r |\s |\t |\u |\v |\w |\x |\y |\z |\{ |\| |\} 
                            |\~ |\Space |\Newline)))
         T)))

(STRING-CHAR-P

  (LAMBDA (CHAR)
    (\DTEST CHAR (QUOTE CHARACTER))))

(UPPER-CASE-P

  (LAMBDA (CHAR)
    (<= (CONSTANT (CHAR-CODE
 |\A))
     (CHAR-CODE
 CHAR)
     (CONSTANT (CHAR-CODE
 |\Z)))))
)
(DEFINEQ

(CHAR-EQUAL

  (LAMBDA N
                                                  (* jop: "25-Aug-86 16:03")

    (CL:IF (< N 1)
           (CL:ERROR "CHAR-EQUAL takes at least one arg"))
    (CL:DO ((TEST (CHAR-UPCASE
 (ARG N 1)))
            (I 2 (1+ I)))
           ((> I N)
            T)
           (CL:IF (NOT (EQ TEST (CHAR-UPCASE
 (ARG N I))))
                  (RETURN NIL)))))

(CHAR-GREATERP

  (LAMBDA N
                                                  (* jop: "25-Aug-86 17:15")

    (CL:IF (< N 1)
           (CL:ERROR "CHAR-LESSP takes at least one arg"))
    (CL:DO ((LAST (%%CHAR-UPCASE-CODE (CHAR-CODE
 (ARG N 1))))
            NEXT
            (I 2 (1+ I)))
           ((> I N)
            T)
           (SETQ NEXT (%%CHAR-UPCASE-CODE (CHAR-CODE
 (ARG N I))))
           (CL:IF (NOT (> LAST NEXT))
                  (RETURN NIL)
                  (SETQ LAST NEXT)))))

(CHAR-LESSP

  (LAMBDA N
                                                  (* jop: "25-Aug-86 17:17")

    (CL:IF (< N 1)
           (CL:ERROR "CHAR-LESSP takes at least one arg"))
    (CL:DO ((LAST (%%CHAR-UPCASE-CODE (CHAR-CODE
 (ARG N 1))))
            NEXT
            (I 2 (1+ I)))
           ((> I N)
            T)
           (SETQ NEXT (%%CHAR-UPCASE-CODE (CHAR-CODE
 (ARG N I))))
           (CL:IF (NOT (< LAST NEXT))
                  (RETURN NIL)
                  (SETQ LAST NEXT)))))

(CHAR-NOT-EQUAL

  (LAMBDA N
                                                  (* jop: "25-Aug-86 16:02")

    (CL:IF (< N 1)
           (CL:ERROR "CHAR-NOT-EQUAL takes at least one arg"))
    (CL:DO ((I 1 (1+ I))
            TEST)
           ((> I N)
            T)
           (SETQ TEST (CHAR-UPCASE
 (ARG N I)))
           (CL:IF (CL:DO ((J (1+ I)
                             (1+ J)))
                         ((> J N)
                          NIL)
                         (CL:IF (EQ TEST (CHAR-UPCASE
 (ARG N J)))
                                (RETURN T)))
                  (RETURN NIL)))))

(CHAR-NOT-GREATERP

  (LAMBDA N
                                                  (* jop: "25-Aug-86 17:18")

    (CL:IF (< N 1)
           (CL:ERROR "CHAR-LESSP takes at least one arg"))
    (CL:DO ((LAST (%%CHAR-UPCASE-CODE (CHAR-CODE
 (ARG N 1))))
            NEXT
            (I 2 (1+ I)))
           ((> I N)
            T)
           (SETQ NEXT (%%CHAR-UPCASE-CODE (CHAR-CODE
 (ARG N I))))
           (CL:IF (NOT (<= LAST NEXT))
                  (RETURN NIL)
                  (SETQ LAST NEXT)))))

(CHAR-NOT-LESSP

  (LAMBDA N
                                                  (* jop: "25-Aug-86 17:19")

    (CL:IF (< N 1)
           (CL:ERROR "CHAR-LESSP takes at least one arg"))
    (CL:DO ((LAST (%%CHAR-UPCASE-CODE (CHAR-CODE
 (ARG N 1))))
            NEXT
            (I 2 (1+ I)))
           ((> I N)
            T)
           (SETQ NEXT (%%CHAR-UPCASE-CODE (CHAR-CODE
 (ARG N I))))
           (CL:IF (NOT (>= LAST NEXT))
                  (RETURN NIL)
                  (SETQ LAST NEXT)))))

(CHAR/=

  (LAMBDA N
                                                  (* jop: "25-Aug-86 17:07")

    (CL:IF (< N 1)
           (CL:ERROR "CHAR/= takes at least one arg"))
    (CL:DO ((I 1 (1+ I))
            TEST)
           ((> I N)
            T)
           (SETQ TEST (CHAR-CODE
 (ARG N I)))
           (CL:IF (CL:DO ((J (1+ I)
                             (1+ J)))
                         ((> J N)
                          NIL)
                         (CL:IF (EQ TEST (CHAR-CODE
 (ARG N J)))
                                (RETURN T)))
                  (RETURN NIL)))))

(CHAR<

  (LAMBDA N
                                                  (* jop: "25-Aug-86 14:29")

    (CL:IF (< N 1)
           (CL:ERROR "CHAR< takes at least one arg"))
    (CL:DO ((LAST (CHAR-CODE
 (ARG N 1)))
            NEXT
            (I 2 (1+ I)))
           ((> I N)
            T)
           (SETQ NEXT (CHAR-CODE
 (ARG N I)))
           (CL:IF (NOT (< LAST NEXT))
                  (RETURN NIL)
                  (SETQ LAST NEXT)))))

(CHAR<=

  (LAMBDA N
                                                  (* jop: "25-Aug-86 14:38")

    (CL:IF (< N 1)
           (CL:ERROR "CHAR< takes at least one arg"))
    (CL:DO ((LAST (CHAR-CODE
 (ARG N 1)))
            NEXT
            (I 2 (1+ I)))
           ((> I N)
            T)
           (SETQ NEXT (CHAR-CODE
 (ARG N I)))
           (CL:IF (NOT (<= LAST NEXT))
                  (RETURN NIL)
                  (SETQ LAST NEXT)))))

(CHAR=

  (LAMBDA N
                                                  (* jop: "25-Aug-86 17:05")

    (CL:IF (< N 1)
           (CL:ERROR "CHAR= takes at least one arg"))
    (CL:DO ((TEST (CHAR-CODE
 (ARG N 1)))
            (I 2 (1+ I)))
           ((> I N)
            T)
           (CL:IF (NOT (EQ TEST (CHAR-CODE
 (ARG N I))))
                  (RETURN NIL)))))

(CHAR>

  (LAMBDA N
                                                  (* jop: "25-Aug-86 14:34")

    (CL:IF (< N 1)
           (CL:ERROR "CHAR< takes at least one arg"))
    (CL:DO ((LAST (CHAR-CODE
 (ARG N 1)))
            NEXT
            (I 2 (1+ I)))
           ((> I N)
            T)
           (SETQ NEXT (CHAR-CODE
 (ARG N I)))
           (CL:IF (NOT (> LAST NEXT))
                  (RETURN NIL)
                  (SETQ LAST NEXT)))))

(CHAR>=

  (LAMBDA N
                                                  (* jop: "25-Aug-86 14:40")

    (CL:IF (< N 1)
           (CL:ERROR "CHAR< takes at least one arg"))
    (CL:DO ((LAST (CHAR-CODE
 (ARG N 1)))
            NEXT
            (I 2 (1+ I)))
           ((> I N)
            T)
           (SETQ NEXT (CHAR-CODE
 (ARG N I)))
           (CL:IF (NOT (>= LAST NEXT))
                  (RETURN NIL)
                  (SETQ LAST NEXT)))))
)
(DEFUN DIGIT-CHAR-P
 (CHAR &OPTIONAL (RADIX 10)) 
        "Returns the weigh of CHAR in radix RADIX, or NIL if CHAR is not a digit char in that radix."
   (LET* ((CODE (CHAR-CODE CHAR))
          (VAL (COND
                  ((<= (CONSTANT (CHAR-CODE |\0))
                    CODE
                    (CONSTANT (CHAR-CODE |\9)))
                   (- CODE (CONSTANT (CHAR-CODE |\0))))
                  ((<= (CONSTANT (CHAR-CODE |\A))
                    CODE
                    (CONSTANT (CHAR-CODE |\Z)))
                   (+ 10 (- CODE (CONSTANT (CHAR-CODE |\A)))))
                  ((<= (CONSTANT (CHAR-CODE |\a))
                    CODE
                    (CONSTANT (CHAR-CODE |\z)))
                   (+ 10 (- CODE (CONSTANT (CHAR-CODE |\a))))))))
         (AND VAL (< VAL RADIX)
              VAL)))

(DEFOPTIMIZER CHAR-EQUAL
 (CHAR &REST MORE-CHARS)
   (CL:IF (EQL 1 (CL:LENGTH MORE-CHARS))
          (BQUOTE (EQ (%%CHAR-UPCASE-CODE (CHAR-CODE (\, CHAR)))
                      (%%CHAR-UPCASE-CODE (CHAR-CODE (\, (CAR MORE-CHARS))))))
          (QUOTE COMPILER:PASS)))

(DEFOPTIMIZER CHAR-GREATERP
 (CHAR &REST MORE-CHARS)
   (BQUOTE (> (%%CHAR-UPCASE-CODE (CHAR-CODE (\, CHAR)))
              (\,@ (CL:MAPCAR (FUNCTION (CL:LAMBDA (FORM)
                                               (BQUOTE (%%CHAR-UPCASE-CODE (CHAR-CODE (\, FORM))))))
                          MORE-CHARS)))))

(DEFOPTIMIZER CHAR-LESSP
 (CHAR &REST MORE-CHARS)
   (BQUOTE (< (%%CHAR-UPCASE-CODE (CHAR-CODE (\, CHAR)))
            (\,@ (CL:MAPCAR (FUNCTION (CL:LAMBDA (FORM)
                                             (BQUOTE (%%CHAR-UPCASE-CODE (CHAR-CODE (\, FORM))))))
                        MORE-CHARS)))))

(DEFOPTIMIZER CHAR-NOT-EQUAL
 (CHAR &REST MORE-CHARS)
   (CL:IF (EQL 1 (CL:LENGTH MORE-CHARS))
          (BQUOTE (NOT (EQ (%%CHAR-UPCASE-CODE (CHAR-CODE (\, CHAR)))
                           (%%CHAR-UPCASE-CODE (CHAR-CODE (\, (CAR MORE-CHARS)))))))
          (QUOTE COMPILER:PASS)))

(DEFOPTIMIZER CHAR-NOT-GREATERP
 (CHAR &REST MORE-CHARS)
   (BQUOTE (<= (%%CHAR-UPCASE-CODE (CHAR-CODE (\, CHAR)))
            (\,@ (CL:MAPCAR (FUNCTION (CL:LAMBDA (FORM)
                                             (BQUOTE (%%CHAR-UPCASE-CODE (CHAR-CODE (\, FORM))))))
                        MORE-CHARS)))))

(DEFOPTIMIZER CHAR-NOT-LESSP
 (CHAR &REST MORE-CHARS)
   (BQUOTE (>= (%%CHAR-UPCASE-CODE (CHAR-CODE (\, CHAR)))
               (\,@ (CL:MAPCAR (FUNCTION (CL:LAMBDA (FORM)
                                                (BQUOTE (%%CHAR-UPCASE-CODE (CHAR-CODE (\, FORM))))))
                           MORE-CHARS)))))

(DEFOPTIMIZER CHAR/=
 (CHAR &REST MORE-CHARS) (CL:IF (EQL 1 (CL:LENGTH MORE-CHARS))
                                                    (BQUOTE (NOT (EQ (CHAR-CODE (\, CHAR))
                                                                     (CHAR-CODE (\, (CAR MORE-CHARS))
                                                                            ))))
                                                    (QUOTE COMPILER:PASS)))

(DEFOPTIMIZER CHAR<
 (CHAR &REST MORE-CHARS)
   (BQUOTE (< (CHAR-CODE (\, CHAR))
            (\,@ (CL:MAPCAR (FUNCTION (CL:LAMBDA (FORM)
                                             (BQUOTE (CHAR-CODE (\, FORM)))))
                        MORE-CHARS)))))

(DEFOPTIMIZER CHAR<=
 (CHAR &REST MORE-CHARS)
   (BQUOTE (<= (CHAR-CODE (\, CHAR))
            (\,@ (CL:MAPCAR (FUNCTION (CL:LAMBDA (FORM)
                                             (BQUOTE (CHAR-CODE (\, FORM)))))
                        MORE-CHARS)))))

(DEFOPTIMIZER CHAR=
 (CHAR &REST MORE-CHARS) (CL:IF (EQL 1 (CL:LENGTH MORE-CHARS))
                                                   (BQUOTE (EQ (CHAR-CODE (\, CHAR))
                                                               (CHAR-CODE (\, (CAR MORE-CHARS)))))
                                                   (QUOTE COMPILER:PASS)))

(DEFOPTIMIZER CHAR>
 (CHAR &REST MORE-CHARS)
   (BQUOTE (> (CHAR-CODE (\, CHAR))
              (\,@ (CL:MAPCAR (FUNCTION (CL:LAMBDA (FORM)
                                               (BQUOTE (CHAR-CODE (\, FORM)))))
                          MORE-CHARS)))))

(DEFOPTIMIZER CHAR>=
 (CHAR &REST MORE-CHARS)
   (BQUOTE (>= (CHAR-CODE (\, CHAR))
               (\,@ (CL:MAPCAR (FUNCTION (CL:LAMBDA (FORM)
                                                (BQUOTE (CHAR-CODE (\, FORM)))))
                           MORE-CHARS)))))

(DEFOPTIMIZER CHARACTERP
 (OBJECT) (BQUOTE (TYPENAMEP (\, OBJECT)
                                                 (QUOTE CHARACTER))))

(DEFOPTIMIZER LOWER-CASE-P
 (CHAR) (BQUOTE (<= (CONSTANT (CHAR-CODE |\a))
                                           (CHAR-CODE (\, CHAR))
                                           (CONSTANT (CHAR-CODE |\z)))))

(DEFOPTIMIZER STRING-CHAR-P
 (CHAR) (BQUOTE (\DTEST (\, CHAR)
                                                  (QUOTE CHARACTER))))

(DEFOPTIMIZER UPPER-CASE-P
 (CHAR) (BQUOTE (<= (CONSTANT (CHAR-CODE |\A))
                                           (CHAR-CODE (\, CHAR))
                                           (CONSTANT (CHAR-CODE |\Z)))))

(* * "Internals")


(DEFMACRO %%CHAR-DOWNCASE-CODE
 (CODE) (BQUOTE (LET ((%%CODE (\, CODE)))
                                                   (CL:IF (<= (CONSTANT (CHAR-CODE |\A))
                                                           %%CODE
                                                           (CONSTANT (CHAR-CODE |\Z)))
                                                          (+ %%CODE (- (CONSTANT (CHAR-CODE |\a))
                                                                       (CONSTANT (CHAR-CODE |\A))))
                                                          %%CODE))))

(DEFMACRO %%CHAR-UPCASE-CODE
 (CODE) (BQUOTE (LET ((%%CODE (\, CODE)))
                                                 (CL:IF (<= (CONSTANT (CHAR-CODE |\a))
                                                         %%CODE
                                                         (CONSTANT (CHAR-CODE |\z)))
                                                        (- %%CODE (- (CONSTANT (CHAR-CODE |\a))
                                                                     (CONSTANT (CHAR-CODE |\A))))
                                                        %%CODE))))

(DEFMACRO %%CODE-CHAR
 (CODE) (BQUOTE (\VAG2 \CHARHI (\, CODE))))

(* * "Compiler options")



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

(LOCALVARS . T)
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 CHARCODE)

(ADDTOVAR LAMA
 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 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (4372 7681 (CHARCODE 4382 . 4445) (CHARCODE.DECODE 4447 . 7469) (CHARCODE.UNDECODE 7471
 . 7679)) (10907 11273 (CHAR-CODE 10917 . 11074) (CHAR-INT 11076 . 11132) (INT-CHAR 11134 . 11271)) (
12823 14530 (CHARACTER.READ 12833 . 13866) (CHARACTER.PRINT 13868 . 14528)) (14776 21040 (CHAR-BIT 
14786 . 14940) (CHAR-BITS 14942 . 15097) (CHAR-DOWNCASE 15099 . 15277) (CHAR-FONT 15279 . 15434) (
CHAR-NAME 15436 . 16772) (CHAR-UPCASE 16774 . 16948) (CL:CHARACTER 16950 . 17456) (NAME-CHAR 17458 . 
20878) (SET-CHAR-BIT 20880 . 21038)) (22567 25780 (ALPHA-CHAR-P 22577 . 23099) (ALPHANUMERICP 23101 . 
23290) (BOTH-CASE-P 23292 . 23390) (CHARACTERP 23392 . 23545) (GRAPHIC-CHAR-P 23547 . 24709) (
LOWER-CASE-P 24711 . 24849) (STANDARD-CHAR-P 24851 . 25563) (STRING-CHAR-P 25565 . 25638) (
UPPER-CASE-P 25640 . 25778)) (25781 31699 (CHAR-EQUAL 25791 . 26185) (CHAR-GREATERP 26187 . 26701) (
CHAR-LESSP 26703 . 27214) (CHAR-NOT-EQUAL 27216 . 27831) (CHAR-NOT-GREATERP 27833 . 28352) (
CHAR-NOT-LESSP 28354 . 28870) (CHAR/= 28872 . 29467) (CHAR< 29469 . 29928) (CHAR<= 29930 . 30391) (
CHAR= 30393 . 30773) (CHAR> 30775 . 31234) (CHAR>= 31236 . 31697)))))
STOP