(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)

(FILECREATED "18-Oct-93 10:35:22" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLCHARACTER.;2"
 39407  

      previous date%: "24-Mar-92 14:42:50" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLCHARACTER.;1"
)


(* ; "
Copyright (c) 1985, 1986, 1987, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT CMLCHARACTERCOMS)

(RPAQQ CMLCHARACTERCOMS

       [(COMS                                                (* ; 

                                         "Interlisp CHARCODE; Some is here, the rest is in LLREAD.")

              (FNS CHARCODE CHARCODE.UNDECODE)
              (PROP MACRO SELCHARQ ALPHACHARP DIGITCHARP UCASECODE)
              (OPTIMIZERS CHARCODE)
              (ALISTS (DWIMEQUIVLST SELCHARQ)
                     (PRETTYEQUIVLST SELCHARQ)))
        (COMS                                                (* ; "Common Lisp CHARACTER type")

              (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CHARACTER))
              (VARIABLES \CHARHI)
              (VARIABLES LISP:CHAR-BITS-LIMIT LISP:CHAR-CODE-LIMIT LISP:CHAR-CONTROL-BIT 
                     LISP:CHAR-FONT-LIMIT LISP:CHAR-HYPER-BIT LISP:CHAR-META-BIT LISP:CHAR-SUPER-BIT)
              )
        (COMS                                                (* ; "Basic character fns")

              (FNS LISP:CHAR-CODE LISP:CHAR-INT LISP:INT-CHAR)
              (FUNCTIONS LISP:CODE-CHAR)
              (OPTIMIZERS LISP:CHAR-CODE LISP:CHAR-INT LISP:CODE-CHAR LISP:INT-CHAR))
        [COMS                                                (* ; 

                                                        "I/O; Some is here, the rest is in LLREAD.")

              (FNS CHARACTER.PRINT)
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (SETTOPVAL (\TYPEGLOBALVARIABLE 'CHARACTER T)
                                                        (NTYPX (LISP:CODE-CHAR 0 0 0)))
                                                 (DEFPRINT 'CHARACTER 'CHARACTER.PRINT]
        (COMS 
              (* ;; "Common lisp character functions")


              (FNS LISP:CHAR-BIT LISP:CHAR-BITS LISP:CHAR-DOWNCASE LISP:CHAR-FONT LISP:CHAR-NAME 
                   LISP:CHAR-UPCASE LISP:CHARACTER LISP:NAME-CHAR LISP:SET-CHAR-BIT)
              (FUNCTIONS LISP:DIGIT-CHAR LISP:MAKE-CHAR LISP::BASE-CHARACTER-P 
                     LISP::EXTENDED-CHARACTER-P)
              (OPTIMIZERS LISP:CHAR-UPCASE LISP:CHAR-DOWNCASE LISP:MAKE-CHAR))
        (COMS 
              (* ;; "Predicates")


              (FNS LISP:ALPHA-CHAR-P LISP:ALPHANUMERICP LISP:BOTH-CASE-P LISP:CHARACTERP 
                   LISP:GRAPHIC-CHAR-P LISP:LOWER-CASE-P LISP:STANDARD-CHAR-P LISP:STRING-CHAR-P 
                   LISP:UPPER-CASE-P)
              (FNS LISP:CHAR-EQUAL LISP:CHAR-GREATERP LISP:CHAR-LESSP LISP:CHAR-NOT-EQUAL 
                   LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-LESSP LISP:CHAR/= LISP:CHAR< LISP:CHAR<= 
                   LISP:CHAR= LISP:CHAR> LISP:CHAR>=)
              (FUNCTIONS LISP:DIGIT-CHAR-P)
              (OPTIMIZERS LISP:CHAR-EQUAL LISP:CHAR-GREATERP LISP:CHAR-LESSP LISP:CHAR-NOT-EQUAL 
                     LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-LESSP LISP:CHAR/= LISP:CHAR< LISP:CHAR<= 
                     LISP:CHAR= LISP:CHAR> LISP:CHAR>= LISP:CHARACTERP LISP:LOWER-CASE-P 
                     LISP:STRING-CHAR-P LISP:UPPER-CASE-P))
        (COMS 
              (* ;; "Internals")


              (FUNCTIONS %%CHAR-DOWNCASE-CODE %%CHAR-UPCASE-CODE %%CODE-CHAR))
        (COMS 
              (* ;; "Compiler options")


              (PROP FILETYPE CMLCHARACTER)
              (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA)
                      (NLAML)
                      (LAMA LISP:CHAR>= LISP:CHAR> LISP:CHAR= LISP:CHAR<= LISP:CHAR< LISP:CHAR/= 
                            LISP:CHAR-NOT-LESSP LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-EQUAL 
                            LISP:CHAR-LESSP LISP:CHAR-GREATERP LISP:CHAR-EQUAL])



(* ; "Interlisp CHARCODE; Some is here, the rest is in LLREAD.")


(DEFINEQ

(CHARCODE

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

(CHARCODE.UNDECODE

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

    (LET [(NAME (LISP:CHAR-NAME
 (LISP:CODE-CHAR
 CODE]
         (AND NAME (MKSTRING NAME])
)

(PUTPROPS SELCHARQ
 MACRO
 [F (CONS '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))))

(DEFOPTIMIZER CHARCODE
 (C)
                           (KWOTE (CHARCODE.DECODE C T)))

(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 'CHARACTER]
                         (CREATE
 (\VAG2 \CHARHI CODE)))
)
)

(LISP:DEFCONSTANT \CHARHI
 7)

(LISP:DEFCONSTANT LISP:CHAR-BITS-LIMIT
 1)

(LISP:DEFCONSTANT LISP:CHAR-CODE-LIMIT
 65536)

(LISP:DEFCONSTANT LISP:CHAR-CONTROL-BIT
 0)

(LISP:DEFCONSTANT LISP:CHAR-FONT-LIMIT
 1)

(LISP:DEFCONSTANT LISP:CHAR-HYPER-BIT
 0)

(LISP:DEFCONSTANT LISP:CHAR-META-BIT
 0)

(LISP:DEFCONSTANT LISP:CHAR-SUPER-BIT
 0)



(* ; "Basic character fns")


(DEFINEQ

(LISP:CHAR-CODE

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

    (\LOLOC (\DTEST CHAR 'CHARACTER])

(LISP:CHAR-INT

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

(LISP:INT-CHAR

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

    (LISP:CODE-CHAR
 INTEGER])
)

(LISP:DEFUN LISP:CODE-CHAR
 (CODE &OPTIONAL (BITS 0)
                                     (FONT 0))
   (LISP:IF (AND (EQ BITS 0)
                 (EQ FONT 0)

                 (* ;; "This checks for smallposp")


                 (EQ (\HILOC CODE)
                     \SmallPosHi)

                 (* ;; "Character 255 is undefined in all char sets")


                 (NOT (EQ (LDB (BYTE 8 0)
                               CODE)
                          255)))
          (%%CODE-CHAR
 CODE)))

(DEFOPTIMIZER LISP:CHAR-CODE
 (CHAR)
                                 [LET [(CONSTANT-CHAR (AND (LISP:CONSTANTP CHAR)
                                                           (LISP:EVAL CHAR]
                                      (LISP:IF (LISP:CHARACTERP
 CONSTANT-CHAR)
                                          (\LOLOC CONSTANT-CHAR)
                                          `(\LOLOC (\DTEST ,CHAR 'CHARACTER)))])

(DEFOPTIMIZER LISP:CHAR-INT
 (CHAR)
                                `(LISP:CHAR-CODE
 ,CHAR))

(DEFOPTIMIZER LISP:CODE-CHAR
 (CODE &OPTIONAL (BITS 0)
                                       (FONT 0))
                                 (LISP:IF (AND (EQ BITS 0)
                                               (EQ FONT 0))
                                     [LET
                                      [(CONSTANT-CODE (AND (LISP:CONSTANTP CODE)
                                                           (LISP:EVAL CODE]
                                      (LISP:IF (EQ (\HILOC CONSTANT-CODE)
                                                   \SmallPosHi)
                                          (LISP:IF (NOT (EQ (LDB (BYTE 8 0)
                                                                 CONSTANT-CODE)
                                                            255))
                                                 (%%CODE-CHAR
 CONSTANT-CODE))
                                          `(LET ((%%CODE ,CODE))
                                                (AND (EQ (\HILOC %%CODE)
                                                         ,\SmallPosHi)
                                                     (NOT (EQ (LDB (BYTE 8 0)
                                                                   %%CODE)
                                                              255))
                                                     (%%CODE-CHAR
 %%CODE))))]
                                     'COMPILER:PASS))

(DEFOPTIMIZER LISP:INT-CHAR
 (INTEGER)
                                `(LISP:CODE-CHAR
 ,INTEGER))



(* ; "I/O; Some is here, the rest is in LLREAD.")


(DEFINEQ

(CHARACTER.PRINT

  [LAMBDA (CHAR STREAM)                                      (* ; "Edited 23-Sep-91 21:09 by jrb:")

    [COND
       [*PRINT-ESCAPE*                                       (* ; "Name that can be read back")

              (LET ((PNAME (LISP:CHAR-NAME
 CHAR))
                    LPN)
                   [.SPACECHECK. STREAM (+ 2 (COND
                                                (PNAME (SETQ LPN (LISP:LENGTH PNAME)))
                                                (T 1]        (* ; 

                                                           "Print as #\ followed by charcter name")

                   (\OUTCHAR STREAM (fetch
 (READTABLEP HASHMACROCHAR) of
 *READTABLE*))
                   (\OUTCHAR STREAM (CHARCODE
 "\"))
                   (COND
                      (PNAME (WRITE-STRING* PNAME STREAM 0 LPN))
                      (T (\OUTCHAR STREAM (LISP:CHAR-CODE
 CHAR]
       (T                                                    (* ; "Character as character")

          (\OUTCHAR STREAM (LISP:CHAR-CODE
 CHAR]
    T])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(SETTOPVAL (\TYPEGLOBALVARIABLE 'CHARACTER T)
       (NTYPX (LISP:CODE-CHAR
 0 0 0)))

(DEFPRINT 'CHARACTER 'CHARACTER.PRINT)
)



(* ;; "Common lisp character functions")


(DEFINEQ

(LISP:CHAR-BIT

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

    (LISP:ERROR "Bit ~A not supported" NAME])

(LISP:CHAR-BITS

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

    (AND (LISP:CHARACTERP
 CHAR)
         0])

(LISP:CHAR-DOWNCASE

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

    (%%CODE-CHAR
 (%%CHAR-DOWNCASE-CODE
 (LISP:CHAR-CODE
 CHAR])

(LISP:CHAR-FONT

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

    (AND (LISP:CHARACTERP
 CHAR)
         0])

(LISP:CHAR-NAME

  [LAMBDA (CHAR)                                             (* ; "Edited 19-Mar-87 15:49 by bvm:")

    (DECLARE
 (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES))
    (COND
       ((EQ CHAR #\Space)                                    (* ; 

                                            "Space is special because it is graphic but has a name")

        "Space")
       ((LISP:GRAPHIC-CHAR-P
 CHAR)                       (* ; "graphics have no special names")

        NIL)
       (T (LET ((CODE (LISP:CHAR-CODE
 CHAR))
                CSET)
               (COND
                  [(for
 X in
 CHARACTERNAMES when
 (EQ (CADR X)
                                                                 CODE)
                      do
 (RETURN (CAR X]
                  (T (SETQ CSET (LRSH CODE 8))
                     (SETQ CODE (LOGAND CODE 255))
                     (COND
                        [(AND (EQ CSET 0)
                              (<= CODE (CHARCODE
 "^Z"))) (* ; 

                                                           "represent ascii control chars nicely")

                         (CONCAT "^" (LISP:CODE-CHAR
 (LOGOR CODE (- (CHARCODE
 "A")
                                                                        (CHARCODE
 "^A"]
                        (T                                   (* ; "Else charset-charcode")

                           (CONCAT (for
 X in
 CHARACTERSETNAMES
                                      when
 (EQ (CADR X)
                                                   CSET) do
 (RETURN (CAR X))
                                      finally
 (RETURN (OCTALSTRING CSET)))
                                  "-"
                                  (OCTALSTRING CODE])

(LISP:CHAR-UPCASE

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

    (%%CODE-CHAR
 (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 CHAR])

(LISP:CHARACTER

  [LAMBDA (OBJECT)                                           (* jop%: "14-Nov-86 16:22")

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

(LISP:NAME-CHAR

  [LAMBDA (NAME)                                             (* ; "Edited 18-Feb-87 22:05 by bvm:")

    (LET ((CODE (CHARCODE.DECODE (STRING NAME)
                       T)))
         (AND CODE (LISP:CODE-CHAR
 CODE])

(LISP:SET-CHAR-BIT

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

    (LISP:ERROR "Bit ~A not supported" NAME])
)

(LISP:DEFUN LISP:DIGIT-CHAR
 (WEIGHT &OPTIONAL (RADIX 10)
                                       (FONT 0))
   [AND (EQ FONT 0)
        (< -1 WEIGHT RADIX 37)
        (LISP:IF (< WEIGHT 10)
            (%%CODE-CHAR
 (+ (CONSTANT (LISP:CHAR-CODE
 #\0))
                                WEIGHT))
            (%%CODE-CHAR
 (+ (CONSTANT (LISP:CHAR-CODE
 #\A))
                                (- WEIGHT 10))))])

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

(LISP:DEFUN LISP::BASE-CHARACTER-P
 (LISP::OBJECT)        (* ; "Edited 13-Feb-92 19:51 by jrb:")

   (AND (LISP:CHARACTERP
 LISP::OBJECT)

        (* ;; "Same as (NOT (%%%%FAT-STRING-CHAR-P object))")


        (ILEQ (\LOLOC LISP::OBJECT)
              %%MAXTHINCHAR)))

(LISP:DEFUN LISP::EXTENDED-CHARACTER-P
 (LISP::OBJECT)    (* ; "Edited 13-Feb-92 20:18 by jrb:")

   (AND (LISP:CHARACTERP
 LISP::OBJECT)

        (* ;; "Same as (%%%%FAT-STRING-CHAR-P object)")


        (IGREATERP (\LOLOC LISP::OBJECT)
               %%MAXTHINCHAR)))

(DEFOPTIMIZER LISP:CHAR-UPCASE
 (CHAR)
                                   `[%%CODE-CHAR
 (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE

                                                                              ,CHAR])

(DEFOPTIMIZER LISP:CHAR-DOWNCASE
 (CHAR)
                                     `[%%CODE-CHAR
 (%%CHAR-DOWNCASE-CODE
 (LISP:CHAR-CODE

                                                                                  ,CHAR])

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



(* ;; "Predicates")


(DEFINEQ

(LISP:ALPHA-CHAR-P

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

    (LET ((CODE (LISP:CHAR-CODE
 CHAR)))                  (* ; 

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

         (OR (<= (CONSTANT (LISP:CHAR-CODE
 #\A))
                 CODE
                 (CONSTANT (LISP:CHAR-CODE
 #\Z)))
             (<= (CONSTANT (LISP:CHAR-CODE
 #\a))
                 CODE
                 (CONSTANT (LISP:CHAR-CODE
 #\z])

(LISP:ALPHANUMERICP

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

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

(LISP:BOTH-CASE-P

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

(LISP:CHARACTERP

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

    (TYPENAMEP OBJECT 'CHARACTER])

(LISP: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 (LISP: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 (LISP:CHAR-CODE
 #\Space)))
                          (AND (> (SETQ CODE (LOGAND CODE 127))
                                  32)
                               (NOT (EQ CODE 127])

(LISP:LOWER-CASE-P

  [LAMBDA (CHAR)
    (<= (CONSTANT (LISP:CHAR-CODE
 #\a))
        (LISP:CHAR-CODE
 CHAR)
        (CONSTANT (LISP:CHAR-CODE
 #\z])

(LISP:STANDARD-CHAR-P

  [LAMBDA (CHAR)                                             (* ; "Edited  7-Jan-87 11:42 by jop")

    (AND (LISP:MEMBER CHAR
                '(#\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\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])

(LISP:STRING-CHAR-P

  [LAMBDA (CHAR)
    (\DTEST CHAR 'CHARACTER])

(LISP:UPPER-CASE-P

  [LAMBDA (CHAR)
    (<= (CONSTANT (LISP:CHAR-CODE
 #\A))
        (LISP:CHAR-CODE
 CHAR)
        (CONSTANT (LISP:CHAR-CODE
 #\Z])
)
(DEFINEQ

(LISP:CHAR-EQUAL

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

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

(LISP:CHAR-GREATERP

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

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

(LISP:CHAR-LESSP

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

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

(LISP:CHAR-NOT-EQUAL

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

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

(LISP:CHAR-NOT-GREATERP

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

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

(LISP:CHAR-NOT-LESSP

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

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

(LISP:CHAR/=

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

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

(LISP:CHAR<

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

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

(LISP:CHAR<=

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

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

(LISP:CHAR=

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

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

(LISP:CHAR>

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

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

(LISP:CHAR>=

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

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

(LISP:DEFUN LISP: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 (LISP:CHAR-CODE
 CHAR))
          (VAL (COND
                  [(<= (CONSTANT (LISP:CHAR-CODE
 #\0))
                       CODE
                       (CONSTANT (LISP:CHAR-CODE
 #\9)))
                   (- CODE (CONSTANT (LISP:CHAR-CODE
 #\0]
                  [(<= (CONSTANT (LISP:CHAR-CODE
 #\A))
                       CODE
                       (CONSTANT (LISP:CHAR-CODE
 #\Z)))
                   (+ 10 (- CODE (CONSTANT (LISP:CHAR-CODE
 #\A]
                  ((<= (CONSTANT (LISP:CHAR-CODE
 #\a))
                       CODE
                       (CONSTANT (LISP:CHAR-CODE
 #\z)))
                   (+ 10 (- CODE (CONSTANT (LISP:CHAR-CODE
 #\a]
         (AND VAL (< VAL RADIX)
              VAL)))

(DEFOPTIMIZER LISP:CHAR-EQUAL
 (CHAR &REST MORE-CHARS)
                                  (LISP:IF (EQL 1 (LISP:LENGTH MORE-CHARS))
                                      `[EQ (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 ,CHAR))
                                           (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE

                                                                    ,(CAR MORE-CHARS]
                                      'COMPILER:PASS))

(DEFOPTIMIZER LISP:CHAR-GREATERP
 (CHAR &REST MORE-CHARS)
                                     `(> (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 ,CHAR))
                                         ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA
                                                                   (FORM)
                                                                   `(%%CHAR-UPCASE-CODE

                                                                     (LISP:CHAR-CODE
 ,FORM]
                                                  MORE-CHARS)))

(DEFOPTIMIZER LISP:CHAR-LESSP
 (CHAR &REST MORE-CHARS)
                                  `(< (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 ,CHAR))
                                      ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA
                                                                (FORM)
                                                                `(%%CHAR-UPCASE-CODE

                                                                  (LISP:CHAR-CODE
 ,FORM]
                                               MORE-CHARS)))

(DEFOPTIMIZER LISP:CHAR-NOT-EQUAL
 (CHAR &REST MORE-CHARS)
                                      (LISP:IF (EQL 1 (LISP:LENGTH MORE-CHARS))
                                          `[NOT (EQ (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE

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

                                                     (LISP:CHAR-CODE
 ,(CAR MORE-CHARS]
                                          'COMPILER:PASS))

(DEFOPTIMIZER LISP:CHAR-NOT-GREATERP
 (CHAR &REST MORE-CHARS)
                                         `(<=
                                           (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 ,CHAR))
                                           ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA
                                                                     (FORM)
                                                                     `(%%CHAR-UPCASE-CODE

                                                                       (LISP:CHAR-CODE

                                                                        ,FORM]
                                                    MORE-CHARS)))

(DEFOPTIMIZER LISP:CHAR-NOT-LESSP
 (CHAR &REST MORE-CHARS)
                                      `(>= (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 ,CHAR))
                                           ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA
                                                                     (FORM)
                                                                     `(%%CHAR-UPCASE-CODE

                                                                       (LISP:CHAR-CODE

                                                                        ,FORM]
                                                    MORE-CHARS)))

(DEFOPTIMIZER LISP:CHAR/=
 (CHAR &REST MORE-CHARS)
                              (LISP:IF (CDR MORE-CHARS)
                                  'COMPILER:PASS
                                  `(NEQ ,CHAR ,(CAR MORE-CHARS))))

(DEFOPTIMIZER LISP:CHAR<
 (CHAR &REST MORE-CHARS)
                             `(< (LISP:CHAR-CODE
 ,CHAR)
                                 ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA (FORM)
                                                                 `(LISP:CHAR-CODE
 ,FORM]
                                          MORE-CHARS)))

(DEFOPTIMIZER LISP:CHAR<=
 (CHAR &REST MORE-CHARS)
                              `(<= (LISP:CHAR-CODE
 ,CHAR)
                                   ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA (FORM)
                                                                   `(LISP:CHAR-CODE
 ,FORM]
                                            MORE-CHARS)))

(DEFOPTIMIZER LISP:CHAR=
 (CHAR &REST MORE-CHARS)
                             (LISP:IF (CDR MORE-CHARS)
                                 [LET
                                  ((CH (GENSYM)))
                                  `(LET ((,CH ,CHAR))
                                        (AND ,@(for
 X in
 MORE-CHARS
                                                  collect
 `(EQ ,CH ,X]
                                 `(EQ ,CHAR ,(CAR MORE-CHARS))))

(DEFOPTIMIZER LISP:CHAR>
 (CHAR &REST MORE-CHARS)
                             `(> (LISP:CHAR-CODE
 ,CHAR)
                                 ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA (FORM)
                                                                 `(LISP:CHAR-CODE
 ,FORM]
                                          MORE-CHARS)))

(DEFOPTIMIZER LISP:CHAR>=
 (CHAR &REST MORE-CHARS)
                              `(>= (LISP:CHAR-CODE
 ,CHAR)
                                   ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA (FORM)
                                                                   `(LISP:CHAR-CODE
 ,FORM]
                                            MORE-CHARS)))

(DEFOPTIMIZER LISP:CHARACTERP
 (OBJECT)
                                  `(TYPENAMEP ,OBJECT 'CHARACTER))

(DEFOPTIMIZER LISP:LOWER-CASE-P
 (CHAR)
                                    `(<= (CONSTANT (LISP:CHAR-CODE
 #\a))
                                         (LISP:CHAR-CODE
 ,CHAR)
                                         (CONSTANT (LISP:CHAR-CODE
 #\z))))

(DEFOPTIMIZER LISP:STRING-CHAR-P
 (CHAR)
                                     `(\DTEST ,CHAR 'CHARACTER))

(DEFOPTIMIZER LISP:UPPER-CASE-P
 (CHAR)
                                    `(<= (CONSTANT (LISP:CHAR-CODE
 #\A))
                                         (LISP:CHAR-CODE
 ,CHAR)
                                         (CONSTANT (LISP:CHAR-CODE
 #\Z))))



(* ;; "Internals")



(DEFMACRO %%CHAR-DOWNCASE-CODE
 (CODE)
   `(LET ((%%CODE ,CODE))
         (LISP:IF (<= (CONSTANT (LISP:CHAR-CODE
 #\A))
                      %%CODE
                      (CONSTANT (LISP:CHAR-CODE
 #\Z)))
             [+ %%CODE (- (CONSTANT (LISP:CHAR-CODE
 #\a))
                          (CONSTANT (LISP:CHAR-CODE
 #\A]
             %%CODE)))

(DEFMACRO %%CHAR-UPCASE-CODE
 (CODE)
   `(LET ((%%CODE ,CODE))
         (LISP:IF (<= (CONSTANT (LISP:CHAR-CODE
 #\a))
                      %%CODE
                      (CONSTANT (LISP:CHAR-CODE
 #\z)))
             [- %%CODE (- (CONSTANT (LISP:CHAR-CODE
 #\a))
                          (CONSTANT (LISP:CHAR-CODE
 #\A]
             %%CODE)))

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



(* ;; "Compiler options")



(PUTPROPS CMLCHARACTER
 FILETYPE
 LISP: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
 )

(ADDTOVAR LAMA
 LISP:CHAR>= LISP:CHAR> LISP:CHAR= LISP:CHAR<= LISP:CHAR< LISP:CHAR/= 
                         LISP:CHAR-NOT-LESSP LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-EQUAL 
                         LISP:CHAR-LESSP LISP:CHAR-GREATERP LISP:CHAR-EQUAL)
)
(PRETTYCOMPRINT CMLCHARACTERCOMS)

(RPAQQ CMLCHARACTERCOMS

       [(COMS                                                (* ; 

                                         "Interlisp CHARCODE; Some is here, the rest is in LLREAD.")

              (FNS CHARCODE CHARCODE.UNDECODE)
              (PROP MACRO SELCHARQ ALPHACHARP DIGITCHARP UCASECODE)
              (OPTIMIZERS CHARCODE)
              (ALISTS (DWIMEQUIVLST SELCHARQ)
                     (PRETTYEQUIVLST SELCHARQ)))
        (COMS                                                (* ; "Common Lisp CHARACTER type")

              (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CHARACTER))
              (VARIABLES \CHARHI)
              (VARIABLES LISP:CHAR-BITS-LIMIT LISP:CHAR-CODE-LIMIT LISP:CHAR-CONTROL-BIT 
                     LISP:CHAR-FONT-LIMIT LISP:CHAR-HYPER-BIT LISP:CHAR-META-BIT LISP:CHAR-SUPER-BIT)
              )
        (COMS                                                (* ; "Basic character fns")

              (FNS LISP:CHAR-CODE LISP:CHAR-INT LISP:INT-CHAR)
              (FUNCTIONS LISP:CODE-CHAR)
              (OPTIMIZERS LISP:CHAR-CODE LISP:CHAR-INT LISP:CODE-CHAR LISP:INT-CHAR))
        [COMS                                                (* ; 

                                                        "I/O; Some is here, the rest is in LLREAD.")

              (FNS CHARACTER.PRINT)
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (SETTOPVAL (\TYPEGLOBALVARIABLE 'CHARACTER T)
                                                        (NTYPX (LISP:CODE-CHAR 0 0 0)))
                                                 (DEFPRINT 'CHARACTER 'CHARACTER.PRINT]
        (COMS 
              (* ;; "Common lisp character functions")


              (FNS LISP:CHAR-BIT LISP:CHAR-BITS LISP:CHAR-DOWNCASE LISP:CHAR-FONT LISP:CHAR-NAME 
                   LISP:CHAR-UPCASE LISP:CHARACTER LISP:NAME-CHAR LISP:SET-CHAR-BIT)
              (FUNCTIONS LISP:DIGIT-CHAR LISP:MAKE-CHAR LISP::BASE-CHARACTER-P 
                     LISP::EXTENDED-CHARACTER-P)
              (OPTIMIZERS LISP:CHAR-UPCASE LISP:CHAR-DOWNCASE LISP:MAKE-CHAR))
        (COMS 
              (* ;; "Predicates")


              (FNS LISP:ALPHA-CHAR-P LISP:ALPHANUMERICP LISP:BOTH-CASE-P LISP:CHARACTERP 
                   LISP:GRAPHIC-CHAR-P LISP:LOWER-CASE-P LISP:STANDARD-CHAR-P LISP:STRING-CHAR-P 
                   LISP:UPPER-CASE-P)
              (FNS LISP:CHAR-EQUAL LISP:CHAR-GREATERP LISP:CHAR-LESSP LISP:CHAR-NOT-EQUAL 
                   LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-LESSP LISP:CHAR/= LISP:CHAR< LISP:CHAR<= 
                   LISP:CHAR= LISP:CHAR> LISP:CHAR>=)
              (FUNCTIONS LISP:DIGIT-CHAR-P)
              (OPTIMIZERS LISP:CHAR-EQUAL LISP:CHAR-GREATERP LISP:CHAR-LESSP LISP:CHAR-NOT-EQUAL 
                     LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-LESSP LISP:CHAR/= LISP:CHAR< LISP:CHAR<= 
                     LISP:CHAR= LISP:CHAR> LISP:CHAR>= LISP:CHARACTERP LISP:LOWER-CASE-P 
                     LISP:STRING-CHAR-P LISP:UPPER-CASE-P))
        (COMS 
              (* ;; "Internals")


              (FUNCTIONS %%CHAR-DOWNCASE-CODE %%CHAR-UPCASE-CODE %%CODE-CHAR))
        (COMS 
              (* ;; "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 LISP:CHAR>= LISP:CHAR> LISP:CHAR= LISP:CHAR<= LISP:CHAR< LISP:CHAR/= 
                            LISP:CHAR-NOT-LESSP LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-EQUAL 
                            LISP:CHAR-LESSP LISP:CHAR-GREATERP LISP:CHAR-EQUAL])
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 CHARCODE)

(ADDTOVAR LAMA
 LISP:CHAR>= LISP:CHAR> LISP:CHAR= LISP:CHAR<= LISP:CHAR< LISP:CHAR/= 
                         LISP:CHAR-NOT-LESSP LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-EQUAL 
                         LISP:CHAR-LESSP LISP:CHAR-GREATERP LISP:CHAR-EQUAL)
)
(PUTPROPS CMLCHARACTER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1991 1992 1993))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4234 4520 (CHARCODE 4244 . 4303) (CHARCODE.UNDECODE 4305 . 4518)) (7120 7495 (
LISP:CHAR-CODE 7130 . 7280) (LISP:CHAR-INT 7282 . 7348) (LISP:INT-CHAR 7350 . 7493)) (10135 11239 (
CHARACTER.PRINT 10145 . 11237)) (11454 15081 (LISP:CHAR-BIT 11464 . 11621) (LISP:CHAR-BITS 11623 . 
11784) (LISP:CHAR-DOWNCASE 11786 . 11976) (LISP:CHAR-FONT 11978 . 12139) (LISP:CHAR-NAME 12141 . 13934
) (LISP:CHAR-UPCASE 13936 . 14122) (LISP:CHARACTER 14124 . 14670) (LISP:NAME-CHAR 14672 . 14916) (
LISP:SET-CHAR-BIT 14918 . 15079)) (17155 20389 (LISP:ALPHA-CHAR-P 17165 . 17711) (LISP:ALPHANUMERICP 
17713 . 17913) (LISP:BOTH-CASE-P 17915 . 18028) (LISP:CHARACTERP 18030 . 18176) (LISP:GRAPHIC-CHAR-P 
18178 . 19317) (LISP:LOWER-CASE-P 19319 . 19480) (LISP:STANDARD-CHAR-P 19482 . 20152) (LISP:STRING-CHAR-P
 20154 . 20224) (LISP:UPPER-CASE-P 20226 . 20387)) (20390 26570 (LISP:CHAR-EQUAL 20400 . 20818) (
LISP:CHAR-GREATERP 20820 . 21353) (LISP:CHAR-LESSP 21355 . 21885) (LISP:CHAR-NOT-EQUAL 21887 . 22537) 
(LISP:CHAR-NOT-GREATERP 22539 . 23077) (LISP:CHAR-NOT-LESSP 23079 . 23614) (LISP:CHAR/= 23616 . 24246)
 (LISP:CHAR< 24248 . 24724) (LISP:CHAR<= 24726 . 25204) (LISP:CHAR= 25206 . 25610) (LISP:CHAR> 25612
 . 26088) (LISP:CHAR>= 26090 . 26568)))))
STOP