(FILECREATED "14-Oct-86 19:35:13" {ERIS}<LISPCORE>SOURCES>CMLCHARACTER.;5 32536
changes to: (VARS CMLCHARACTERCOMS)
previous date: "25-Sep-86 10:37:24" {ERIS}<LISPCORE>SOURCES>CMLCHARACTER.;4)
(* "
Copyright (c) 1985, 1986 by 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))
(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))
(COMS (* ; "Basic character fns")
(FNS CHAR-CODE CHAR-INT INT-CHAR)
(FUNCTIONS CODE-CHAR)
(OPTIMIZERS CHAR-CODE CHAR-INT CODE-CHAR INT-CHAR))
(COMS (* ; "I/O; Some is here, the rest is in LLREAD.")
(FNS CHARACTER.PRINT)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER)
T)
(NTYPX (CODE-CHAR 0 0 0)))
(DEFPRINT (QUOTE CHARACTER)
(QUOTE CHARACTER.PRINT)))))
(COMS (* ;; "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))
(COMS (* ;; "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))
(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 CHAR>= CHAR> CHAR= CHAR<= CHAR< CHAR/= CHAR-NOT-LESSP CHAR-NOT-GREATERP
CHAR-NOT-EQUAL CHAR-LESSP CHAR-GREATERP 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 (CHAR-NAME (CODE-CHAR CODE))))
(AND NAME (MKSTRING NAME)))))
)
(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))))
(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 (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 (SMALLP %%CODE)
(<= 0 %%CODE)
(%%CODE-CHAR %%CODE))))
))
(T (QUOTE COMPILER:PASS))))
(DEFOPTIMIZER INT-CHAR (INTEGER) (BQUOTE (CODE-CHAR (\, INTEGER))))
(* ; "I/O; Some is here, the rest is in LLREAD.")
(DEFINEQ
(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 (CDR MORE-CHARS)
(QUOTE COMPILER:PASS)
(BQUOTE (NEQ (\, CHAR)
(\, (CAR 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)
(BQUOTE (<= (CHAR-CODE (\, CHAR))
(\,@ (CL:MAPCAR (FUNCTION (CL:LAMBDA (FORM)
(BQUOTE (CHAR-CODE (\, FORM)))))
MORE-CHARS)))))
(DEFOPTIMIZER CHAR= (CHAR &REST MORE-CHARS)
(CL:IF (CDR MORE-CHARS)
(LET ((CH (GENSYM)))
(BQUOTE (LET (((\, CH)
(\, CHAR)))
(AND (\,@ (for X in MORE-CHARS collect (BQUOTE (EQ (\, CH)
(\, X)))))))))
(BQUOTE (EQ (\, CHAR)
(\, (CAR 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)
(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 (3327 3613 (CHARCODE 3337 . 3401) (CHARCODE.UNDECODE 3403 . 3611)) (5788 6152 (CHAR-CODE
5798 . 5955) (CHAR-INT 5957 . 6014) (INT-CHAR 6016 . 6150)) (7692 8364 (CHARACTER.PRINT 7702 . 8362))
(8613 14884 (CHAR-BIT 8623 . 8777) (CHAR-BITS 8779 . 8934) (CHAR-DOWNCASE 8936 . 9114) (CHAR-FONT
9116 . 9271) (CHAR-NAME 9273 . 10609) (CHAR-UPCASE 10611 . 10785) (CL:CHARACTER 10787 . 11300) (
NAME-CHAR 11302 . 14722) (SET-CHAR-BIT 14724 . 14882)) (16414 19629 (ALPHA-CHAR-P 16424 . 16946) (
ALPHANUMERICP 16948 . 17137) (BOTH-CASE-P 17139 . 17239) (CHARACTERP 17241 . 17394) (GRAPHIC-CHAR-P
17396 . 18558) (LOWER-CASE-P 18560 . 18698) (STANDARD-CHAR-P 18700 . 19412) (STRING-CHAR-P 19414 .
19487) (UPPER-CASE-P 19489 . 19627)) (19630 25548 (CHAR-EQUAL 19640 . 20034) (CHAR-GREATERP 20036 .
20550) (CHAR-LESSP 20552 . 21063) (CHAR-NOT-EQUAL 21065 . 21680) (CHAR-NOT-GREATERP 21682 . 22201) (
CHAR-NOT-LESSP 22203 . 22719) (CHAR/= 22721 . 23316) (CHAR< 23318 . 23777) (CHAR<= 23779 . 24240) (
CHAR= 24242 . 24622) (CHAR> 24624 . 25083) (CHAR>= 25085 . 25546)))))
STOP