Modify CL:CHAR-NAME always to return string from lookup in IL:CHARACTERNAMES. (#1377)
This *seems* to fix the issue with printing "control characters" in #\Name format.
This commit is contained in:
Matt Heffron
GitHub
810
sources/CMLARITH
810
sources/CMLARITH
File diff suppressed because it is too large
Load Diff
@@ -1,9 +1,10 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
|
||||
(IL:FILECREATED "13-Jun-2021 21:16:13" ("compiled on "
|
||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>CMLARITH.;1|) "13-Jun-2021 14:44:27"
|
||||
"COMPILE-FILEd" IL:|in| "FULL 13-Jun-2021 ..." IL:|dated| "13-Jun-2021 14:44:40")
|
||||
(IL:FILECREATED " 4-Jan-93 17:38:48" IL:|{DSK}<python>lde>lispcore>sources>CMLARITH.;2| 102283
|
||||
IL:|previous| IL:|date:| "16-May-90 12:46:36" IL:|{DSK}<python>lde>lispcore>sources>CMLARITH.;1|)
|
||||
(DEFINE-FILE-INFO PACKAGE "LISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
(IL:FILECREATED "24-Sep-2023 15:37:41" ("compiled on " IL:|{WMEDLEY}<sources>CMLARITH.;3|)
|
||||
"24-Sep-2023 15:27:49" "COMPILE-FILEd" IL:|in| "FULL 24-Sep-2023 ..." IL:|dated|
|
||||
"24-Sep-2023 15:27:56")
|
||||
(IL:FILECREATED "24-Sep-2023 15:37:27" IL:|{WMEDLEY}<sources>CMLARITH.;3| 100379 :EDIT-BY IL:|rmk|
|
||||
:PREVIOUS-DATE "23-Sep-2023 23:15:39" IL:|{WMEDLEY}<sources>CMLARITH.;2|)
|
||||
(IL:RPAQQ IL:CMLARITHCOMS ((IL:* IL:|;;;| "Common Lisp Arithmetic ") (IL:COMS (IL:* IL:|;;|
|
||||
"Error utilities") (IL:FUNCTIONS %NOT-NUMBER-ERROR %NOT-NONCOMPLEX-NUMBER-ERROR %NOT-INTEGER-ERROR
|
||||
%NOT-RATIONAL-ERROR %NOT-FLOAT-ERROR)) (IL:COMS (IL:* IL:|;;;| "Section 2.1.2 Ratios. ") (IL:COMS (
|
||||
@@ -1145,6 +1146,4 @@ NIL
|
||||
(QUOTE LDB-TEST) (QUOTE COMPILER:OPTIMIZER-LIST))))
|
||||
(IL:PUTPROPS IL:CMLARITH IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
|
||||
(IL:PUTPROPS IL:CMLARITH IL:FILETYPE COMPILE-FILE)
|
||||
(IL:PUTPROPS IL:CMLARITH IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1989 1990 1993)
|
||||
)
|
||||
NIL
|
||||
|
||||
@@ -1,50 +1,53 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "28-Jun-99 21:54:32" {DSK}<project>medley3.5>sources>CMLCHARACTER.;2 32559
|
||||
|
||||
changes to%: (OPTIMIZERS CL:CODE-CHAR)
|
||||
(FUNCTIONS CL:CODE-CHAR)
|
||||
(FILECREATED "30-Oct-2023 18:04:29" {DSK}<home>matt>Interlisp>medley>sources>CMLCHARACTER.;4 32004
|
||||
|
||||
previous date%: "18-Aug-95 14:45:44" {DSK}<project>medley3.5>sources>CMLCHARACTER.;1)
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:CHANGES-TO (FNS CL:CHAR-NAME)
|
||||
|
||||
:PREVIOUS-DATE "17-Oct-2023 13:16:14" {DSK}<home>matt>Interlisp>medley>sources>CMLCHARACTER.;1
|
||||
)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1985, 1986, 1987, 1990, 1995, 1999 by Venue & Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1985-1987, 1990, 1995, 1999, 2023 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT CMLCHARACTERCOMS)
|
||||
|
||||
(RPAQQ CMLCHARACTERCOMS
|
||||
[(COMS (* ;
|
||||
"Interlisp CHARCODE; Some is here, the rest is in LLREAD.")
|
||||
[(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")
|
||||
(COMS (* ; "Common Lisp CHARACTER type")
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CHARACTER))
|
||||
(VARIABLES \CHARHI)
|
||||
(VARIABLES CL:CHAR-BITS-LIMIT CL:CHAR-CODE-LIMIT CL:CHAR-CONTROL-BIT CL:CHAR-FONT-LIMIT
|
||||
CL:CHAR-HYPER-BIT CL:CHAR-META-BIT CL:CHAR-SUPER-BIT))
|
||||
(COMS (* ; "Basic character fns")
|
||||
(COMS (* ; "Basic character fns")
|
||||
(FNS CL:CHAR-CODE CL:CHAR-INT CL:INT-CHAR)
|
||||
(FUNCTIONS CL:CODE-CHAR)
|
||||
(OPTIMIZERS CL:CHAR-CODE CL:CHAR-INT CL:CODE-CHAR CL:INT-CHAR))
|
||||
[COMS (* ;
|
||||
"I/O; Some is here, the rest is in LLREAD.")
|
||||
[COMS (* ;
|
||||
"I/O; Some is here, the rest is in LLREAD.")
|
||||
(FNS CHARACTER.PRINT)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (SETTOPVAL (\TYPEGLOBALVARIABLE 'CHARACTER T)
|
||||
(NTYPX (CL:CODE-CHAR 0 0 0)))
|
||||
(DEFPRINT 'CHARACTER 'CHARACTER.PRINT]
|
||||
(COMS
|
||||
(* ;; "Common lisp character functions")
|
||||
(* ;; "Common lisp character functions")
|
||||
|
||||
(FNS CL:CHAR-BIT CL:CHAR-BITS CL:CHAR-DOWNCASE CL:CHAR-FONT CL:CHAR-NAME CL:CHAR-UPCASE
|
||||
CL:CHARACTER CL:NAME-CHAR CL:SET-CHAR-BIT)
|
||||
(FUNCTIONS CL:DIGIT-CHAR CL:MAKE-CHAR)
|
||||
(OPTIMIZERS CL:CHAR-UPCASE CL:CHAR-DOWNCASE CL:MAKE-CHAR))
|
||||
(COMS
|
||||
(* ;; "Predicates")
|
||||
(* ;; "Predicates")
|
||||
|
||||
(FNS CL:ALPHA-CHAR-P CL:ALPHANUMERICP CL:BOTH-CASE-P CL:CHARACTERP CL:GRAPHIC-CHAR-P
|
||||
CL:LOWER-CASE-P CL:STANDARD-CHAR-P CL:STRING-CHAR-P CL:UPPER-CASE-P)
|
||||
@@ -57,11 +60,11 @@ Copyright (c) 1985, 1986, 1987, 1990, 1995, 1999 by Venue & Xerox Corporation.
|
||||
CL:CHAR> CL:CHAR>= CL:CHARACTERP CL:LOWER-CASE-P CL:STRING-CHAR-P
|
||||
CL:UPPER-CASE-P))
|
||||
(COMS
|
||||
(* ;; "Internals")
|
||||
(* ;; "Internals")
|
||||
|
||||
(FUNCTIONS %%CHAR-DOWNCASE-CODE %%CHAR-UPCASE-CODE %%CODE-CHAR))
|
||||
(COMS
|
||||
(* ;; "Compiler options")
|
||||
(* ;; "Compiler options")
|
||||
|
||||
(PROP FILETYPE CMLCHARACTER)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)))
|
||||
@@ -89,36 +92,35 @@ Copyright (c) 1985, 1986, 1987, 1990, 1995, 1999 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(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])
|
||||
(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))))
|
||||
([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])
|
||||
(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))))
|
||||
(COND
|
||||
((AND (IGEQ CHAR (CHARCODE a))
|
||||
(ILEQ CHAR (CHARCODE z)))
|
||||
(LOGAND CHAR 95))
|
||||
(T CHAR))))
|
||||
|
||||
(DEFOPTIMIZER CHARCODE (C)
|
||||
(KWOTE (CHARCODE.DECODE C T)))
|
||||
(KWOTE (CHARCODE.DECODE C T)))
|
||||
|
||||
(ADDTOVAR DWIMEQUIVLST (SELCHARQ . SELECTQ))
|
||||
|
||||
@@ -132,7 +134,7 @@ Copyright (c) 1985, 1986, 1987, 1990, 1995, 1999 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS CHARACTER [(CODE (\LOLOC (\DTEST DATUM 'CHARACTER]
|
||||
(CREATE (\VAG2 \CHARHI CODE)))
|
||||
(CREATE (\VAG2 \CHARHI CODE)))
|
||||
)
|
||||
)
|
||||
|
||||
@@ -172,43 +174,43 @@ Copyright (c) 1985, 1986, 1987, 1990, 1995, 1999 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(CL:DEFUN CL:CODE-CHAR (CODE &OPTIONAL (BITS 0)
|
||||
(FONT 0))
|
||||
(FONT 0))
|
||||
(CL:IF (AND (EQ BITS 0)
|
||||
(EQ FONT 0)
|
||||
|
||||
(* ;; "This checks for smallposp")
|
||||
(* ;; "This checks for smallposp")
|
||||
|
||||
(EQ (\HILOC CODE)
|
||||
\SmallPosHi))
|
||||
(%%CODE-CHAR CODE)))
|
||||
|
||||
(DEFOPTIMIZER CL:CHAR-CODE (CHAR)
|
||||
[LET [(CONSTANT-CHAR (AND (CL:CONSTANTP CHAR)
|
||||
(CL:EVAL CHAR]
|
||||
(CL:IF (CL:CHARACTERP CONSTANT-CHAR)
|
||||
(\LOLOC CONSTANT-CHAR)
|
||||
`(\LOLOC (\DTEST ,CHAR 'CHARACTER)))])
|
||||
[LET [(CONSTANT-CHAR (AND (CL:CONSTANTP CHAR)
|
||||
(CL:EVAL CHAR]
|
||||
(CL:IF (CL:CHARACTERP CONSTANT-CHAR)
|
||||
(\LOLOC CONSTANT-CHAR)
|
||||
`(\LOLOC (\DTEST ,CHAR 'CHARACTER)))])
|
||||
|
||||
(DEFOPTIMIZER CL:CHAR-INT (CHAR)
|
||||
`(CL:CHAR-CODE ,CHAR))
|
||||
`(CL:CHAR-CODE ,CHAR))
|
||||
|
||||
(DEFOPTIMIZER CL:CODE-CHAR (CODE &OPTIONAL (BITS 0)
|
||||
(FONT 0))
|
||||
(CL:IF (AND (EQ BITS 0)
|
||||
(EQ FONT 0))
|
||||
[LET [(CONSTANT-CODE (AND (CL:CONSTANTP CODE)
|
||||
(CL:EVAL CODE]
|
||||
(CL:IF (EQ (\HILOC CONSTANT-CODE)
|
||||
\SmallPosHi)
|
||||
(%%CODE-CHAR CONSTANT-CODE)
|
||||
`(LET ((%%CODE ,CODE))
|
||||
(AND (EQ (\HILOC %%CODE)
|
||||
,\SmallPosHi)
|
||||
(%%CODE-CHAR %%CODE))))]
|
||||
'COMPILER:PASS))
|
||||
(FONT 0))
|
||||
(CL:IF (AND (EQ BITS 0)
|
||||
(EQ FONT 0))
|
||||
[LET [(CONSTANT-CODE (AND (CL:CONSTANTP CODE)
|
||||
(CL:EVAL CODE]
|
||||
(CL:IF (EQ (\HILOC CONSTANT-CODE)
|
||||
\SmallPosHi)
|
||||
(%%CODE-CHAR CONSTANT-CODE)
|
||||
`(LET ((%%CODE ,CODE))
|
||||
(AND (EQ (\HILOC %%CODE)
|
||||
,\SmallPosHi)
|
||||
(%%CODE-CHAR %%CODE))))]
|
||||
'COMPILER:PASS))
|
||||
|
||||
(DEFOPTIMIZER CL:INT-CHAR (INTEGER)
|
||||
`(CL:CODE-CHAR ,INTEGER))
|
||||
`(CL:CODE-CHAR ,INTEGER))
|
||||
|
||||
|
||||
|
||||
@@ -267,33 +269,39 @@ Copyright (c) 1985, 1986, 1987, 1990, 1995, 1999 by Venue & Xerox Corporation.
|
||||
0])
|
||||
|
||||
(CL:CHAR-NAME
|
||||
[LAMBDA (CHAR) (* ; "Edited 19-Mar-87 15:49 by bvm:")
|
||||
[LAMBDA (CHAR) (* ; "Edited 30-Oct-2023 17:57 by mth")
|
||||
(* ; "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 is special because it is graphic but has a name")
|
||||
"Space")
|
||||
((CL:GRAPHIC-CHAR-P CHAR) (* ; "graphics have no special names")
|
||||
((CL:GRAPHIC-CHAR-P CHAR) (* ; "graphics have no special names")
|
||||
NIL)
|
||||
(T (LET ((CODE (CL:CHAR-CODE CHAR))
|
||||
CSET)
|
||||
(COND
|
||||
[(for X in CHARACTERNAMES when (EQ (CADR X)
|
||||
CODE)
|
||||
do (RETURN (CAR X]
|
||||
CODE) do
|
||||
(* ;;
|
||||
"This assumes that (CAR X) is SYMBOL or STRING!!")
|
||||
|
||||
(* ;;
|
||||
"(Should this be enforced? I.e., error if not?)")
|
||||
|
||||
(RETURN (STRING (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")
|
||||
(<= CODE (CHARCODE "^Z"))) (* ;
|
||||
"represent ascii control chars nicely")
|
||||
(CONCAT "^" (CL:CODE-CHAR (LOGOR CODE (- (CHARCODE "A")
|
||||
(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)))
|
||||
(CONCAT (for X in CHARACTERSETNAMES when (EQ (CADR X)
|
||||
CSET)
|
||||
do (RETURN (CAR X)) finally (RETURN (OCTALSTRING CSET)))
|
||||
"-"
|
||||
(OCTALSTRING CODE])
|
||||
|
||||
@@ -326,36 +334,34 @@ Copyright (c) 1985, 1986, 1987, 1990, 1995, 1999 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(CL:DEFUN CL:DIGIT-CHAR (WEIGHT &OPTIONAL (RADIX 10)
|
||||
(FONT 0))
|
||||
(FONT 0))
|
||||
[AND (EQ FONT 0)
|
||||
(< -1 WEIGHT RADIX 37)
|
||||
(CL:IF (< WEIGHT 10)
|
||||
(%%CODE-CHAR (+ (CONSTANT (CL:CHAR-CODE #\0))
|
||||
WEIGHT))
|
||||
WEIGHT))
|
||||
(%%CODE-CHAR (+ (CONSTANT (CL:CHAR-CODE #\A))
|
||||
(- WEIGHT 10))))])
|
||||
(- WEIGHT 10))))])
|
||||
|
||||
(CL:DEFUN CL:MAKE-CHAR (CHAR &OPTIONAL (BITS 0)
|
||||
(FONT 0))
|
||||
(FONT 0))
|
||||
(CL:IF (AND (EQL BITS 0)
|
||||
(EQL FONT 0))
|
||||
CHAR))
|
||||
|
||||
(DEFOPTIMIZER CL:CHAR-UPCASE (CHAR)
|
||||
`[%%CODE-CHAR (%%CHAR-UPCASE-CODE (CL:CHAR-CODE
|
||||
,CHAR])
|
||||
`[%%CODE-CHAR (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR])
|
||||
|
||||
(DEFOPTIMIZER CL:CHAR-DOWNCASE (CHAR)
|
||||
`[%%CODE-CHAR (%%CHAR-DOWNCASE-CODE (CL:CHAR-CODE
|
||||
,CHAR])
|
||||
`[%%CODE-CHAR (%%CHAR-DOWNCASE-CODE (CL:CHAR-CODE ,CHAR])
|
||||
|
||||
(DEFOPTIMIZER CL:MAKE-CHAR (CHAR &OPTIONAL BITS FONT)
|
||||
(CL:IF (AND (OR (NULL BITS)
|
||||
(EQL BITS 0))
|
||||
(OR (NULL FONT)
|
||||
(EQL FONT 0)))
|
||||
CHAR
|
||||
'COMPILER:PASS))
|
||||
(CL:IF (AND (OR (NULL BITS)
|
||||
(EQL BITS 0))
|
||||
(OR (NULL FONT)
|
||||
(EQL FONT 0)))
|
||||
CHAR
|
||||
'COMPILER:PASS))
|
||||
|
||||
|
||||
|
||||
@@ -627,105 +633,100 @@ Copyright (c) 1985, 1986, 1987, 1990, 1995, 1999 by Venue & Xerox Corporation.
|
||||
VAL)))
|
||||
|
||||
(DEFOPTIMIZER CL:CHAR-EQUAL (CHAR &REST MORE-CHARS)
|
||||
(CL:IF (EQL 1 (CL:LENGTH MORE-CHARS))
|
||||
`[EQ (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR))
|
||||
(%%CHAR-UPCASE-CODE (CL:CHAR-CODE
|
||||
,(CAR MORE-CHARS]
|
||||
'COMPILER:PASS))
|
||||
(CL:IF (EQL 1 (CL:LENGTH MORE-CHARS))
|
||||
`[EQ (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR))
|
||||
(%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,(CAR MORE-CHARS]
|
||||
'COMPILER:PASS))
|
||||
|
||||
(DEFOPTIMIZER CL:CHAR-GREATERP (CHAR &REST MORE-CHARS)
|
||||
`(> (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR))
|
||||
,@(CL:MAPCAR [FUNCTION (CL:LAMBDA
|
||||
(FORM)
|
||||
`(%%CHAR-UPCASE-CODE
|
||||
(CL:CHAR-CODE ,FORM]
|
||||
MORE-CHARS)))
|
||||
`(> (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR))
|
||||
,@(CL:MAPCAR [FUNCTION (CL:LAMBDA
|
||||
(FORM)
|
||||
`(%%CHAR-UPCASE-CODE (CL:CHAR-CODE
|
||||
,FORM]
|
||||
MORE-CHARS)))
|
||||
|
||||
(DEFOPTIMIZER CL:CHAR-LESSP (CHAR &REST MORE-CHARS)
|
||||
`(< (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR))
|
||||
,@(CL:MAPCAR [FUNCTION (CL:LAMBDA
|
||||
(FORM)
|
||||
`(%%CHAR-UPCASE-CODE
|
||||
(CL:CHAR-CODE ,FORM]
|
||||
MORE-CHARS)))
|
||||
`(< (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR))
|
||||
,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM)
|
||||
`(%%CHAR-UPCASE-CODE
|
||||
(CL:CHAR-CODE ,FORM]
|
||||
MORE-CHARS)))
|
||||
|
||||
(DEFOPTIMIZER CL:CHAR-NOT-EQUAL (CHAR &REST MORE-CHARS)
|
||||
(CL:IF (EQL 1 (CL:LENGTH MORE-CHARS))
|
||||
`[NOT (EQ (%%CHAR-UPCASE-CODE (CL:CHAR-CODE
|
||||
,CHAR))
|
||||
(%%CHAR-UPCASE-CODE (CL:CHAR-CODE
|
||||
,(CAR MORE-CHARS]
|
||||
'COMPILER:PASS))
|
||||
(CL:IF (EQL 1 (CL:LENGTH MORE-CHARS))
|
||||
`[NOT (EQ (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR))
|
||||
(%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,(CAR MORE-CHARS]
|
||||
'COMPILER:PASS))
|
||||
|
||||
(DEFOPTIMIZER CL:CHAR-NOT-GREATERP (CHAR &REST MORE-CHARS)
|
||||
`(<= (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR))
|
||||
,@(CL:MAPCAR [FUNCTION (CL:LAMBDA
|
||||
(FORM)
|
||||
`(%%CHAR-UPCASE-CODE
|
||||
(CL:CHAR-CODE ,FORM]
|
||||
MORE-CHARS)))
|
||||
`(<= (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR))
|
||||
,@(CL:MAPCAR [FUNCTION (CL:LAMBDA
|
||||
(FORM)
|
||||
`(%%CHAR-UPCASE-CODE
|
||||
(CL:CHAR-CODE ,FORM]
|
||||
MORE-CHARS)))
|
||||
|
||||
(DEFOPTIMIZER CL:CHAR-NOT-LESSP (CHAR &REST MORE-CHARS)
|
||||
`(>= (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR))
|
||||
,@(CL:MAPCAR [FUNCTION (CL:LAMBDA
|
||||
(FORM)
|
||||
`(%%CHAR-UPCASE-CODE
|
||||
(CL:CHAR-CODE ,FORM]
|
||||
MORE-CHARS)))
|
||||
`(>= (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR))
|
||||
,@(CL:MAPCAR [FUNCTION (CL:LAMBDA
|
||||
(FORM)
|
||||
`(%%CHAR-UPCASE-CODE (CL:CHAR-CODE
|
||||
,FORM]
|
||||
MORE-CHARS)))
|
||||
|
||||
(DEFOPTIMIZER CL:CHAR/= (CHAR &REST MORE-CHARS)
|
||||
(CL:IF (CDR MORE-CHARS)
|
||||
'COMPILER:PASS
|
||||
`(NEQ ,CHAR ,(CAR MORE-CHARS))))
|
||||
(CL:IF (CDR MORE-CHARS)
|
||||
'COMPILER:PASS
|
||||
`(NEQ ,CHAR ,(CAR MORE-CHARS))))
|
||||
|
||||
(DEFOPTIMIZER CL:CHAR< (CHAR &REST MORE-CHARS)
|
||||
`(< (CL:CHAR-CODE ,CHAR)
|
||||
,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM)
|
||||
`(CL:CHAR-CODE ,FORM]
|
||||
MORE-CHARS)))
|
||||
`(< (CL:CHAR-CODE ,CHAR)
|
||||
,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM)
|
||||
`(CL:CHAR-CODE ,FORM]
|
||||
MORE-CHARS)))
|
||||
|
||||
(DEFOPTIMIZER CL:CHAR<= (CHAR &REST MORE-CHARS)
|
||||
`(<= (CL:CHAR-CODE ,CHAR)
|
||||
,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM)
|
||||
`(CL:CHAR-CODE ,FORM]
|
||||
MORE-CHARS)))
|
||||
`(<= (CL:CHAR-CODE ,CHAR)
|
||||
,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM)
|
||||
`(CL:CHAR-CODE ,FORM]
|
||||
MORE-CHARS)))
|
||||
|
||||
(DEFOPTIMIZER CL:CHAR= (CHAR &REST MORE-CHARS)
|
||||
(CL:IF (CDR MORE-CHARS)
|
||||
[LET
|
||||
((CH (GENSYM)))
|
||||
(CL: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))))
|
||||
`(EQ ,CHAR ,(CAR MORE-CHARS))))
|
||||
|
||||
(DEFOPTIMIZER CL:CHAR> (CHAR &REST MORE-CHARS)
|
||||
`(> (CL:CHAR-CODE ,CHAR)
|
||||
,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM)
|
||||
`(CL:CHAR-CODE ,FORM]
|
||||
MORE-CHARS)))
|
||||
`(> (CL:CHAR-CODE ,CHAR)
|
||||
,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM)
|
||||
`(CL:CHAR-CODE ,FORM]
|
||||
MORE-CHARS)))
|
||||
|
||||
(DEFOPTIMIZER CL:CHAR>= (CHAR &REST MORE-CHARS)
|
||||
`(>= (CL:CHAR-CODE ,CHAR)
|
||||
,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM)
|
||||
`(CL:CHAR-CODE ,FORM]
|
||||
MORE-CHARS)))
|
||||
`(>= (CL:CHAR-CODE ,CHAR)
|
||||
,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM)
|
||||
`(CL:CHAR-CODE ,FORM]
|
||||
MORE-CHARS)))
|
||||
|
||||
(DEFOPTIMIZER CL:CHARACTERP (OBJECT)
|
||||
`(TYPENAMEP ,OBJECT 'CHARACTER))
|
||||
`(TYPENAMEP ,OBJECT 'CHARACTER))
|
||||
|
||||
(DEFOPTIMIZER CL:LOWER-CASE-P (CHAR)
|
||||
`(<= (CONSTANT (CL:CHAR-CODE #\a))
|
||||
(CL:CHAR-CODE ,CHAR)
|
||||
(CONSTANT (CL:CHAR-CODE #\z))))
|
||||
`(<= (CONSTANT (CL:CHAR-CODE #\a))
|
||||
(CL:CHAR-CODE ,CHAR)
|
||||
(CONSTANT (CL:CHAR-CODE #\z))))
|
||||
|
||||
(DEFOPTIMIZER CL:STRING-CHAR-P (CHAR)
|
||||
`(\DTEST ,CHAR 'CHARACTER))
|
||||
`(\DTEST ,CHAR 'CHARACTER))
|
||||
|
||||
(DEFOPTIMIZER CL:UPPER-CASE-P (CHAR)
|
||||
`(<= (CONSTANT (CL:CHAR-CODE #\A))
|
||||
(CL:CHAR-CODE ,CHAR)
|
||||
(CONSTANT (CL:CHAR-CODE #\Z))))
|
||||
`(<= (CONSTANT (CL:CHAR-CODE #\A))
|
||||
(CL:CHAR-CODE ,CHAR)
|
||||
(CONSTANT (CL:CHAR-CODE #\Z))))
|
||||
|
||||
|
||||
|
||||
@@ -772,21 +773,24 @@ Copyright (c) 1985, 1986, 1987, 1990, 1995, 1999 by Venue & Xerox Corporation.
|
||||
(ADDTOVAR NLAML CHARCODE)
|
||||
|
||||
(ADDTOVAR LAMA CL:CHAR>= CL:CHAR> CL:CHAR= CL:CHAR<= CL:CHAR< CL:CHAR/= CL:CHAR-NOT-LESSP
|
||||
CL:CHAR-NOT-GREATERP CL:CHAR-NOT-EQUAL CL:CHAR-LESSP CL:CHAR-GREATERP
|
||||
CL:CHAR-EQUAL)
|
||||
CL:CHAR-NOT-GREATERP CL:CHAR-NOT-EQUAL CL:CHAR-LESSP CL:CHAR-GREATERP
|
||||
CL:CHAR-EQUAL)
|
||||
)
|
||||
(PUTPROPS CMLCHARACTER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1995 1999))
|
||||
(PUTPROPS CMLCHARACTER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1995 1999 2023))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4041 4323 (CHARCODE 4051 . 4110) (CHARCODE.UNDECODE 4112 . 4321)) (6868 7233 (
|
||||
CL:CHAR-CODE 6878 . 7026) (CL:CHAR-INT 7028 . 7090) (CL:INT-CHAR 7092 . 7231)) (9139 10193 (
|
||||
CHARACTER.PRINT 9149 . 10191)) (10406 13937 (CL:CHAR-BIT 10416 . 10569) (CL:CHAR-BITS 10571 . 10728) (
|
||||
CL:CHAR-DOWNCASE 10730 . 10916) (CL:CHAR-FONT 10918 . 11075) (CL:CHAR-NAME 11077 . 12860) (
|
||||
CL:CHAR-UPCASE 12862 . 13044) (CL:CHARACTER 13046 . 13534) (CL:NAME-CHAR 13536 . 13776) (CL:SET-CHAR-BIT
|
||||
13778 . 13935)) (15381 18563 (CL:ALPHA-CHAR-P 15391 . 15927) (CL:ALPHANUMERICP 15929 . 16123) (
|
||||
CL:BOTH-CASE-P 16125 . 16232) (CL:CHARACTERP 16234 . 16378) (CL:GRAPHIC-CHAR-P 16380 . 17513) (
|
||||
CL:LOWER-CASE-P 17515 . 17668) (CL:STANDARD-CHAR-P 17670 . 18336) (CL:STRING-CHAR-P 18338 . 18406) (
|
||||
CL:UPPER-CASE-P 18408 . 18561)) (18564 24388 (CL:CHAR-EQUAL 18574 . 18968) (CL:CHAR-GREATERP 18970 .
|
||||
19477) (CL:CHAR-LESSP 19479 . 19983) (CL:CHAR-NOT-EQUAL 19985 . 20585) (CL:CHAR-NOT-GREATERP 20587 .
|
||||
21099) (CL:CHAR-NOT-LESSP 21101 . 21610) (CL:CHAR/= 21612 . 22192) (CL:CHAR< 22194 . 22644) (CL:CHAR<=
|
||||
22646 . 23098) (CL:CHAR= 23100 . 23480) (CL:CHAR> 23482 . 23932) (CL:CHAR>= 23934 . 24386)))))
|
||||
(FILEMAP (NIL (4013 4295 (CHARCODE 4023 . 4082) (CHARCODE.UNDECODE 4084 . 4293)) (6601 6966 (
|
||||
CL:CHAR-CODE 6611 . 6759) (CL:CHAR-INT 6761 . 6823) (CL:INT-CHAR 6825 . 6964)) (6968 7269 (CL:CODE-CHAR
|
||||
6968 . 7269)) (8788 9842 (CHARACTER.PRINT 8798 . 9840)) (10055 14089 (CL:CHAR-BIT 10065 . 10218) (
|
||||
CL:CHAR-BITS 10220 . 10377) (CL:CHAR-DOWNCASE 10379 . 10565) (CL:CHAR-FONT 10567 . 10724) (CL:CHAR-NAME
|
||||
10726 . 13012) (CL:CHAR-UPCASE 13014 . 13196) (CL:CHARACTER 13198 . 13686) (CL:NAME-CHAR 13688 .
|
||||
13928) (CL:SET-CHAR-BIT 13930 . 14087)) (14091 14484 (CL:DIGIT-CHAR 14091 . 14484)) (14486 14650 (
|
||||
CL:MAKE-CHAR 14486 . 14650)) (15329 18511 (CL:ALPHA-CHAR-P 15339 . 15875) (CL:ALPHANUMERICP 15877 .
|
||||
16071) (CL:BOTH-CASE-P 16073 . 16180) (CL:CHARACTERP 16182 . 16326) (CL:GRAPHIC-CHAR-P 16328 . 17461)
|
||||
(CL:LOWER-CASE-P 17463 . 17616) (CL:STANDARD-CHAR-P 17618 . 18284) (CL:STRING-CHAR-P 18286 . 18354) (
|
||||
CL:UPPER-CASE-P 18356 . 18509)) (18512 24336 (CL:CHAR-EQUAL 18522 . 18916) (CL:CHAR-GREATERP 18918 .
|
||||
19425) (CL:CHAR-LESSP 19427 . 19931) (CL:CHAR-NOT-EQUAL 19933 . 20533) (CL:CHAR-NOT-GREATERP 20535 .
|
||||
21047) (CL:CHAR-NOT-LESSP 21049 . 21558) (CL:CHAR/= 21560 . 22140) (CL:CHAR< 22142 . 22592) (CL:CHAR<=
|
||||
22594 . 23046) (CL:CHAR= 23048 . 23428) (CL:CHAR> 23430 . 23880) (CL:CHAR>= 23882 . 24334)) (24338
|
||||
25228 (CL:DIGIT-CHAR-P 24338 . 25228)) (30590 30935 (%%CHAR-DOWNCASE-CODE 30590 . 30935)) (30937 31280
|
||||
(%%CHAR-UPCASE-CODE 30937 . 31280)) (31282 31341 (%%CODE-CHAR 31282 . 31341)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user