LLCHAR: Extend STRING.EQUAL to take CASEARRAY as argument
still defaults to the previously built-in reference to UPPERCASEARRAY
This commit is contained in:
rmkaplan
526
sources/LLCHAR
526
sources/LLCHAR
@@ -1,9 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "21-Jun-2021 18:08:19"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>LLCHAR.;6 108072
|
||||
|
||||
previous date%: "19-Jun-2021 10:00:42"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>LLCHAR.;5)
|
||||
(FILECREATED " 8-Jan-2022 19:08:41" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;8 106473
|
||||
|
||||
:CHANGES-TO (FNS STRING.EQUAL)
|
||||
|
||||
:PREVIOUS-DATE "21-Jun-2021 18:08:19"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;6)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -18,8 +20,8 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
RPLCHARCODE \RPLCHARCODE NTHCHAR RPLSTRING SUBSTRING GNC GNCCODE GLC GLCCODE STREQUAL
|
||||
STRING.EQUAL STRINGP CHCON1 U-CASE L-CASE U-CASEP \SMASHABLESTRING \MAKEWRITABLESTRING
|
||||
\SMASHSTRING \FATTENSTRING)
|
||||
(COMS (* ;
|
||||
"Temporary until low level system is changed to call STRING.EQUAL again")
|
||||
(COMS (* ;
|
||||
"Temporary until low level system is changed to call STRING.EQUAL again")
|
||||
(P (MOVD? 'STRING.EQUAL 'STRING-EQUAL NIL T)
|
||||
(MOVD? 'STRING.EQUAL 'CL::SIMPLE-STRING-EQUAL NIL T)))
|
||||
(FNS \GETBASESTRING \PUTBASESTRING \PUTBASESTRINGFAT GetBcplString SetBcplString)
|
||||
@@ -30,11 +32,11 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(MACROS \PNAMESTRINGPUTCHAR)
|
||||
(OPTIMIZERS FCHARACTER)
|
||||
(I.S.OPRS inpname inatom instring)
|
||||
(* ;
|
||||
"For use when the inner-loop test in the generic operators is too expensive")
|
||||
(* ;
|
||||
"For use when the inner-loop test in the generic operators is too expensive")
|
||||
(I.S.OPRS infatatom inthinatom infatstring inthinstring)
|
||||
(MACROS \CHARCODEP \FATCHARCODEP \THINCHARCODEP)
|
||||
(* ; "For benefit of Masterscope")
|
||||
(* ; "For benefit of Masterscope")
|
||||
(MACROS \GETBASEFAT \GETBASETHIN \PUTBASEFAT \PUTBASETHIN)
|
||||
(MACROS \PUTBASECHAR \GETBASECHAR)
|
||||
(MACROS \CHARSET \CHAR8CODE)
|
||||
@@ -48,7 +50,7 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(INITRESOURCES \NUMSTR \NUMSTR1 \PNAMESTRING)
|
||||
(P (MOVD? 'CHARACTER 'FCHARACTER NIL T))
|
||||
[COMS (FNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY)
|
||||
(* ; "For MAKEINIT")
|
||||
(* ; "For MAKEINIT")
|
||||
(DECLARE%: DONTCOPY (ADDVARS (INEWCOMS (FNS ALLOCSTRING %%COPY-ONED-ARRAY
|
||||
%%COPY-STRING-TO-ARRAY))
|
||||
(* "So %%COPY-ONED-ARRAY will compile properly")
|
||||
@@ -59,7 +61,7 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(DONTCOMPILEFNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY]
|
||||
(DECLARE%: DONTCOPY EVAL@COMPILE (LOCALVARS . T))
|
||||
|
||||
(* ;; "Arrange for the proper compiler")
|
||||
(* ;; "Arrange for the proper compiler")
|
||||
|
||||
(PROP FILETYPE LLCHAR)))
|
||||
(DEFINEQ
|
||||
@@ -966,10 +968,14 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(GO SLOWLP])
|
||||
|
||||
(STRING.EQUAL
|
||||
[LAMBDA (X Y) (* ;
|
||||
"Edited 12-Jan-94 10:01 by sybalsky:mv:envos")
|
||||
[LAMBDA (X Y CASEARRAY) (* ; "Edited 8-Jan-2022 19:08 by rmk")
|
||||
(* ;
|
||||
"Edited 12-Jan-94 10:01 by sybalsky:mv:envos")
|
||||
|
||||
(* ;;; "True if X and Y are equal atoms or strings without respect to alphabetic case")
|
||||
(* ;;; "True if X and Y are equal atoms or strings without respect to alphabetic case.")
|
||||
|
||||
(* ;;
|
||||
"RMK: Added CASEARRAY argument, silly not to extend this to other than the default UPPERCASEARRAY.")
|
||||
|
||||
(PROG (CABASE LEN BASEX OFFSETX FATPX BASEY OFFSETY FATPY C1 C2)
|
||||
(COND
|
||||
@@ -1012,28 +1018,32 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(SETQ OFFSETY (ffetch (STRINGP OFFST) of Y))
|
||||
(SETQ FATPY (ffetch (STRINGP FATSTRINGP) of Y)))
|
||||
(T (RETURN NIL)))
|
||||
(CL:UNLESS CASEARRAY (SETQ CASEARRAY UPPERCASEARRAY))
|
||||
[COND
|
||||
((NEQ (ffetch (ARRAYP TYP) of (\DTEST UPPERCASEARRAY 'ARRAYP))
|
||||
\ST.BYTE) (* ;
|
||||
"Someone smashed UPPERCASEARRAY ?")
|
||||
(SETQ UPPERCASEARRAY (UPPERCASEARRAY]
|
||||
(SETQ CABASE (ffetch (ARRAYP BASE) of UPPERCASEARRAY))
|
||||
((NEQ (ffetch (ARRAYP TYP) of (\DTEST CASEARRAY 'ARRAYP))
|
||||
\ST.BYTE)
|
||||
(IF (EQ CASEARRAY UPPERCASEARRAY)
|
||||
THEN
|
||||
(* ;; "Did someone smashed the UPPERCASEARRAY? We can repair it")
|
||||
|
||||
(SETQ CASEARRAY (SETQ UPPERCASEARRAY (UPPERCASEARRAY)))
|
||||
ELSE (\ILLEGAL.ARG CASEARRAY]
|
||||
(SETQ CABASE (ffetch (ARRAYP BASE) of CASEARRAY))
|
||||
(RETURN (COND
|
||||
[(OR FATPX FATPY) (* ; "Slow case")
|
||||
(for BNX from OFFSETX as BNY from OFFSETY as I to
|
||||
LEN
|
||||
[(OR FATPX FATPY) (* ; "Slow case")
|
||||
(for BNX from OFFSETX as BNY from OFFSETY as I to LEN
|
||||
always (PROGN (SETQ C1 (\GETBASECHAR FATPX BASEX BNX))
|
||||
(SETQ C2 (\GETBASECHAR FATPY BASEY BNY))
|
||||
(COND
|
||||
((OR (IGREATERP C1 \MAXTHINCHAR)
|
||||
(IGREATERP C2 \MAXTHINCHAR))
|
||||
(* ; "Fat chars not alphabetic")
|
||||
(EQ C1 C2))
|
||||
(T (EQ (\GETBASEBYTE CABASE C1)
|
||||
(\GETBASEBYTE CABASE C2]
|
||||
(T (for BNX from OFFSETX as BNY from OFFSETY as I
|
||||
to LEN always (EQ (\GETBASEBYTE CABASE (\GETBASETHIN BASEX BNX))
|
||||
(\GETBASEBYTE CABASE (\GETBASETHIN BASEY BNY])
|
||||
(SETQ C2 (\GETBASECHAR FATPY BASEY BNY))
|
||||
(COND
|
||||
((OR (IGREATERP C1 \MAXTHINCHAR)
|
||||
(IGREATERP C2 \MAXTHINCHAR))
|
||||
(* ; "Fat chars not alphabetic")
|
||||
(EQ C1 C2))
|
||||
(T (EQ (\GETBASEBYTE CABASE C1)
|
||||
(\GETBASEBYTE CABASE C2]
|
||||
(T (for BNX from OFFSETX as BNY from OFFSETY as I to LEN
|
||||
always (EQ (\GETBASEBYTE CABASE (\GETBASETHIN BASEX BNX))
|
||||
(\GETBASEBYTE CABASE (\GETBASETHIN BASEY BNY])
|
||||
|
||||
(STRINGP
|
||||
[LAMBDA (OBJECT) (* jop%: "24-Sep-86 22:58")
|
||||
@@ -1374,141 +1384,136 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS STRINGP ((XREADONLY (fetch (ARRAY-HEADER READ-ONLY-P) of DATUM)
|
||||
(replace (ARRAY-HEADER READ-ONLY-P) of DATUM with NEWVALUE
|
||||
))
|
||||
(XBASE ([OPENLAMBDA (STRING)
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%ARRAY-BASE STRING))
|
||||
(T (fetch (ARRAY-HEADER BASE) of STRING]
|
||||
DATUM)
|
||||
((OPENLAMBDA (STRING NV)
|
||||
(replace (ARRAY-HEADER INDIRECT-P) of STRING with
|
||||
NIL)
|
||||
(replace (ARRAY-HEADER BASE) of STRING with NV)
|
||||
NV)
|
||||
DATUM NEWVALUE))
|
||||
(TYP ((OPENLAMBDA (STRING)
|
||||
(SELECTC (COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%ARRAY-TYPE-NUMBER STRING))
|
||||
(T (fetch (ARRAY-HEADER TYPE-NUMBER) of STRING)))
|
||||
(%%THIN-CHAR-TYPENUMBER
|
||||
\ST.BYTE)
|
||||
(%%FAT-CHAR-TYPENUMBER
|
||||
\ST.POS16)
|
||||
(SHOULDNT "Unknown type-number")))
|
||||
DATUM)
|
||||
([OPENLAMBDA (STRING NV)
|
||||
(LET [(%%NEW-TYPE-NUMBER (SELECTC NV
|
||||
(\ST.BYTE %%THIN-CHAR-TYPENUMBER)
|
||||
(\ST.POS16 %%FAT-CHAR-TYPENUMBER)
|
||||
(SHOULDNT "Unknown typ value"]
|
||||
(COND
|
||||
(replace (ARRAY-HEADER READ-ONLY-P) of DATUM with NEWVALUE))
|
||||
(XBASE ([OPENLAMBDA (STRING)
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%ARRAY-BASE STRING))
|
||||
(T (fetch (ARRAY-HEADER BASE) of STRING]
|
||||
DATUM)
|
||||
((OPENLAMBDA (STRING NV)
|
||||
(replace (ARRAY-HEADER INDIRECT-P) of STRING with NIL)
|
||||
(replace (ARRAY-HEADER BASE) of STRING with NV)
|
||||
NV)
|
||||
DATUM NEWVALUE))
|
||||
(TYP ((OPENLAMBDA (STRING)
|
||||
(SELECTC (COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%SET-ARRAY-TYPE-NUMBER STRING %%NEW-TYPE-NUMBER))
|
||||
(T (replace (ARRAY-HEADER TYPE-NUMBER) of STRING
|
||||
with %%NEW-TYPE-NUMBER]
|
||||
DATUM NEWVALUE))
|
||||
(LENGTH (fetch (ARRAY-HEADER FILL-POINTER) of DATUM)
|
||||
((OPENLAMBDA (STRING NV)
|
||||
(replace (ARRAY-HEADER FILL-POINTER) of STRING with
|
||||
NV)
|
||||
(replace (ARRAY-HEADER TOTAL-SIZE) of STRING with
|
||||
NV)
|
||||
[COND
|
||||
((%%GENERAL-ARRAY-P STRING)
|
||||
(freplace (GENERAL-ARRAY DIMS) of STRING
|
||||
with (LIST NV]
|
||||
NV)
|
||||
DATUM NEWVALUE))
|
||||
(OFFST ([OPENLAMBDA (STRING)
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%ARRAY-OFFSET STRING))
|
||||
(T (fetch (ARRAY-HEADER OFFSET) of STRING]
|
||||
DATUM)
|
||||
([OPENLAMBDA (STRING NV)
|
||||
(COND
|
||||
((NOT (EQ 0 NV))
|
||||
(replace (ARRAY-HEADER DISPLACED-P) of STRING
|
||||
with T)))
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%SET-ARRAY-OFFSET STRING NV))
|
||||
(T (replace (ARRAY-HEADER OFFSET) of STRING with
|
||||
NV]
|
||||
DATUM NEWVALUE))
|
||||
(%%ARRAY-TYPE-NUMBER STRING))
|
||||
(T (fetch (ARRAY-HEADER TYPE-NUMBER) of STRING)))
|
||||
(%%THIN-CHAR-TYPENUMBER
|
||||
\ST.BYTE)
|
||||
(%%FAT-CHAR-TYPENUMBER
|
||||
\ST.POS16)
|
||||
(SHOULDNT "Unknown type-number")))
|
||||
DATUM)
|
||||
([OPENLAMBDA (STRING NV)
|
||||
(LET [(%%NEW-TYPE-NUMBER (SELECTC NV
|
||||
(\ST.BYTE %%THIN-CHAR-TYPENUMBER)
|
||||
(\ST.POS16 %%FAT-CHAR-TYPENUMBER)
|
||||
(SHOULDNT "Unknown typ value"]
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%SET-ARRAY-TYPE-NUMBER STRING %%NEW-TYPE-NUMBER))
|
||||
(T (replace (ARRAY-HEADER TYPE-NUMBER) of STRING with
|
||||
%%NEW-TYPE-NUMBER
|
||||
]
|
||||
DATUM NEWVALUE))
|
||||
(LENGTH (fetch (ARRAY-HEADER FILL-POINTER) of DATUM)
|
||||
((OPENLAMBDA (STRING NV)
|
||||
(replace (ARRAY-HEADER FILL-POINTER) of STRING with NV)
|
||||
(replace (ARRAY-HEADER TOTAL-SIZE) of STRING with NV)
|
||||
[COND
|
||||
((%%GENERAL-ARRAY-P STRING)
|
||||
(freplace (GENERAL-ARRAY DIMS) of STRING with (LIST NV]
|
||||
NV)
|
||||
DATUM NEWVALUE))
|
||||
(OFFST ([OPENLAMBDA (STRING)
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%ARRAY-OFFSET STRING))
|
||||
(T (fetch (ARRAY-HEADER OFFSET) of STRING]
|
||||
DATUM)
|
||||
([OPENLAMBDA (STRING NV)
|
||||
(COND
|
||||
((NOT (EQ 0 NV))
|
||||
(replace (ARRAY-HEADER DISPLACED-P) of STRING with T)))
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%SET-ARRAY-OFFSET STRING NV))
|
||||
(T (replace (ARRAY-HEADER OFFSET) of STRING with NV]
|
||||
DATUM NEWVALUE))
|
||||
|
||||
(* ;; "The rest of these fields only appear when smashing")
|
||||
(* ;; "The rest of these fields only appear when smashing")
|
||||
|
||||
(XFLAGS (LOGAND (fetch (ARRAY-HEADER FLAGS) of DATUM)
|
||||
15)
|
||||
((OPENLAMBDA (STRING)
|
||||
(replace (ARRAY-HEADER ADJUSTABLE-P) of STRING with
|
||||
NIL)
|
||||
(replace (ARRAY-HEADER DISPLACED-P) of STRING with
|
||||
NIL)
|
||||
(replace (ARRAY-HEADER FILL-POINTER-P) of STRING
|
||||
with NIL)
|
||||
(replace (ARRAY-HEADER EXTENDABLE-P) of STRING with
|
||||
NIL))
|
||||
DATUM)))
|
||||
[ACCESSFNS STRINGP
|
||||
((ORIG ((OPENLAMBDA (STRING)
|
||||
1)
|
||||
DATUM)
|
||||
((OPENLAMBDA (STRING NV)
|
||||
(COND
|
||||
((NOT (EQ NV 1))
|
||||
(ERROR "Il:stringp's are always origin 1")))
|
||||
NV)
|
||||
DATUM NEWVALUE)) (* ; "An inoperative field")
|
||||
(SUBSTRINGED ((OPENLAMBDA (STRING)
|
||||
NIL)
|
||||
DATUM)
|
||||
((OPENLAMBDA (STRING NV)
|
||||
(OR (NULL NV)
|
||||
(ERROR "Substringed field not supported")))
|
||||
DATUM NEWVALUE))
|
||||
(READONLY (ffetch (STRINGP XREADONLY) of DATUM)
|
||||
(freplace (STRINGP XREADONLY) of DATUM with
|
||||
NEWVALUE))
|
||||
(FATSTRINGP ((OPENLAMBDA (STRING)
|
||||
(EQ (COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P)
|
||||
of STRING)
|
||||
(%%ARRAY-TYPE-NUMBER STRING))
|
||||
(T (fetch (ARRAY-HEADER TYPE-NUMBER)
|
||||
of STRING)))
|
||||
%%FAT-CHAR-TYPENUMBER))
|
||||
DATUM)
|
||||
([OPENLAMBDA (STRING NV)
|
||||
(LET [(%%NEW-TYPE-NUMBER (COND
|
||||
(NV %%FAT-CHAR-TYPENUMBER)
|
||||
(T %%THIN-CHAR-TYPENUMBER]
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%SET-ARRAY-TYPE-NUMBER STRING %%NEW-TYPE-NUMBER))
|
||||
(T (replace (ARRAY-HEADER TYPE-NUMBER)
|
||||
of STRING with %%NEW-TYPE-NUMBER]
|
||||
DATUM NEWVALUE))
|
||||
(BASE (ffetch (STRINGP XBASE) of DATUM)
|
||||
(freplace (STRINGP XBASE) of DATUM with NEWVALUE]
|
||||
(CREATE (create ONED-ARRAY
|
||||
BASE _ XBASE
|
||||
READ-ONLY-P _ XREADONLY
|
||||
STRING-P _ T
|
||||
DISPLACED-P _ (NOT (EQ OFFST 0))
|
||||
TYPE-NUMBER _ (COND
|
||||
((EQ TYP \ST.POS16)
|
||||
%%FAT-CHAR-TYPENUMBER)
|
||||
(T %%THIN-CHAR-TYPENUMBER))
|
||||
OFFSET _ OFFST
|
||||
FILL-POINTER _ LENGTH
|
||||
TOTAL-SIZE _ LENGTH))
|
||||
(TYPE? (CL:STRINGP DATUM))
|
||||
OFFST _ 0 TYP _ \ST.BYTE LENGTH _ 0)
|
||||
(XFLAGS (LOGAND (fetch (ARRAY-HEADER FLAGS) of DATUM)
|
||||
15)
|
||||
((OPENLAMBDA (STRING)
|
||||
(replace (ARRAY-HEADER ADJUSTABLE-P) of STRING with NIL)
|
||||
(replace (ARRAY-HEADER DISPLACED-P) of STRING with NIL)
|
||||
(replace (ARRAY-HEADER FILL-POINTER-P) of STRING with NIL)
|
||||
(replace (ARRAY-HEADER EXTENDABLE-P) of STRING with NIL))
|
||||
DATUM)))
|
||||
[ACCESSFNS STRINGP ((ORIG ((OPENLAMBDA (STRING)
|
||||
1)
|
||||
DATUM)
|
||||
((OPENLAMBDA (STRING NV)
|
||||
(COND
|
||||
((NOT (EQ NV 1))
|
||||
(ERROR "Il:stringp's are always origin 1")))
|
||||
NV)
|
||||
DATUM NEWVALUE))
|
||||
(* ; "An inoperative field")
|
||||
(SUBSTRINGED ((OPENLAMBDA (STRING)
|
||||
NIL)
|
||||
DATUM)
|
||||
((OPENLAMBDA (STRING NV)
|
||||
(OR (NULL NV)
|
||||
(ERROR "Substringed field not supported")))
|
||||
DATUM NEWVALUE))
|
||||
(READONLY (ffetch (STRINGP XREADONLY) of DATUM)
|
||||
(freplace (STRINGP XREADONLY) of DATUM with NEWVALUE))
|
||||
(FATSTRINGP ((OPENLAMBDA (STRING)
|
||||
(EQ (COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P)
|
||||
of STRING)
|
||||
(%%ARRAY-TYPE-NUMBER STRING))
|
||||
(T (fetch (ARRAY-HEADER TYPE-NUMBER)
|
||||
of STRING)))
|
||||
%%FAT-CHAR-TYPENUMBER))
|
||||
DATUM)
|
||||
([OPENLAMBDA (STRING NV)
|
||||
(LET [(%%NEW-TYPE-NUMBER (COND
|
||||
(NV
|
||||
%%FAT-CHAR-TYPENUMBER
|
||||
)
|
||||
(T
|
||||
%%THIN-CHAR-TYPENUMBER
|
||||
]
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P)
|
||||
of STRING)
|
||||
(%%SET-ARRAY-TYPE-NUMBER STRING
|
||||
%%NEW-TYPE-NUMBER))
|
||||
(T (replace (ARRAY-HEADER TYPE-NUMBER)
|
||||
of STRING with %%NEW-TYPE-NUMBER]
|
||||
DATUM NEWVALUE))
|
||||
(BASE (ffetch (STRINGP XBASE) of DATUM)
|
||||
(freplace (STRINGP XBASE) of DATUM with NEWVALUE]
|
||||
(CREATE (create ONED-ARRAY
|
||||
BASE _ XBASE
|
||||
READ-ONLY-P _ XREADONLY
|
||||
STRING-P _ T
|
||||
DISPLACED-P _ (NOT (EQ OFFST 0))
|
||||
TYPE-NUMBER _ (COND
|
||||
((EQ TYP \ST.POS16)
|
||||
%%FAT-CHAR-TYPENUMBER)
|
||||
(T %%THIN-CHAR-TYPENUMBER))
|
||||
OFFSET _ OFFST
|
||||
FILL-POINTER _ LENGTH
|
||||
TOTAL-SIZE _ LENGTH))
|
||||
(TYPE? (CL:STRINGP DATUM))
|
||||
OFFST _ 0 TYP _ \ST.BYTE LENGTH _ 0)
|
||||
)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
@@ -1531,27 +1536,25 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \PNAMESTRINGPUTCHAR MACRO ((BASE OFFSET CODE)
|
||||
(* ;
|
||||
"For stuffing chars into resource \PNAMESTRING")
|
||||
(\PUTBASECHAR \FATPNAMESTRINGP BASE OFFSET CODE)))
|
||||
(PUTPROPS \PNAMESTRINGPUTCHAR MACRO ((BASE OFFSET CODE) (* ;
|
||||
"For stuffing chars into resource \PNAMESTRING")
|
||||
(\PUTBASECHAR \FATPNAMESTRINGP BASE OFFSET CODE)))
|
||||
)
|
||||
|
||||
(DEFOPTIMIZER FCHARACTER (NUM)
|
||||
`([OPENLAMBDA (N)
|
||||
(COND
|
||||
((IGREATERP N \MAXTHINCHAR)
|
||||
(* ;
|
||||
"The character we're getting is NOT a thin character -- do it the hard way")
|
||||
(CHARACTER N))
|
||||
((IGREATERP N (CHARCODE 9))
|
||||
(\ADDBASE \OneCharAtomBase (IDIFFERENCE N 10)))
|
||||
((IGEQ N (CHARCODE 0))
|
||||
(IDIFFERENCE N (CHARCODE 0)))
|
||||
(T (* ;
|
||||
"The common case -- just add on the one-atom base.")
|
||||
(\ADDBASE \OneCharAtomBase N]
|
||||
,NUM))
|
||||
`([OPENLAMBDA (N)
|
||||
(COND
|
||||
((IGREATERP N \MAXTHINCHAR) (* ;
|
||||
"The character we're getting is NOT a thin character -- do it the hard way")
|
||||
(CHARACTER N))
|
||||
((IGREATERP N (CHARCODE 9))
|
||||
(\ADDBASE \OneCharAtomBase (IDIFFERENCE N 10)))
|
||||
((IGEQ N (CHARCODE 0))
|
||||
(IDIFFERENCE N (CHARCODE 0)))
|
||||
(T (* ;
|
||||
"The common case -- just add on the one-atom base.")
|
||||
(\ADDBASE \OneCharAtomBase N]
|
||||
,NUM))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(I.S.OPR 'inpname NIL '[SUBPAIR '($$END $$BODY $$FATP $$BASE $$OFFSET)
|
||||
@@ -1563,30 +1566,26 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
`(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP
|
||||
declare (LOCALVARS $$END $$BODY $$FATP $$BASE $$OFFSET)
|
||||
first [PROG NIL
|
||||
$$RETRY
|
||||
(COND
|
||||
((STRINGP $$BODY)
|
||||
(SETQ $$BASE (ffetch (STRINGP BASE)
|
||||
of $$BODY))
|
||||
(SETQ $$OFFSET (SUB1 (ffetch (STRINGP
|
||||
OFFST)
|
||||
of $$BODY)))
|
||||
(SETQ $$END (IPLUS $$OFFSET (ffetch
|
||||
(STRINGP
|
||||
LENGTH)
|
||||
of $$BODY)))
|
||||
(SETQ $$FATP (ffetch (STRINGP
|
||||
FATSTRINGP)
|
||||
of $$BODY)))
|
||||
((LITATOM $$BODY)
|
||||
(SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
|
||||
of $$BODY))
|
||||
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
|
||||
of $$BASE))
|
||||
(SETQ $$FATP (ffetch (LITATOM FATPNAMEP)
|
||||
of $$BODY)))
|
||||
(T (SETQ $$BODY (MKSTRING $$BODY))
|
||||
(GO $$RETRY]
|
||||
$$RETRY
|
||||
(COND
|
||||
((STRINGP $$BODY)
|
||||
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY))
|
||||
(SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
|
||||
of $$BODY)))
|
||||
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH
|
||||
)
|
||||
of $$BODY)))
|
||||
(SETQ $$FATP (ffetch (STRINGP FATSTRINGP)
|
||||
of $$BODY)))
|
||||
((LITATOM $$BODY)
|
||||
(SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
|
||||
of $$BODY))
|
||||
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
|
||||
of $$BASE))
|
||||
(SETQ $$FATP (ffetch (LITATOM FATPNAMEP)
|
||||
of $$BODY)))
|
||||
(T (SETQ $$BODY (MKSTRING $$BODY))
|
||||
(GO $$RETRY]
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
@@ -1603,10 +1602,8 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(GETDUMMYVAR))
|
||||
'(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP
|
||||
declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END $$FATP)
|
||||
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY
|
||||
))
|
||||
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE)
|
||||
)
|
||||
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY))
|
||||
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE))
|
||||
(SETQ $$FATP (ffetch (LITATOM FATPNAMEP) of $$BODY))
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
@@ -1624,13 +1621,11 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(GETDUMMYVAR))
|
||||
'(bind $$BODY _ BODY $$END $$OFFSET $$BASE $$FATP
|
||||
declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE $$FATP)
|
||||
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
|
||||
of $$BODY)))
|
||||
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) of $$BODY)))
|
||||
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY))
|
||||
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH)
|
||||
of $$BODY)))
|
||||
(SETQ $$FATP (ffetch (STRINGP FATSTRINGP)
|
||||
of $$BODY))
|
||||
(SETQ $$FATP (ffetch (STRINGP FATSTRINGP) of $$BODY))
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
@@ -1648,10 +1643,8 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(GETDUMMYVAR))
|
||||
'(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END
|
||||
declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END)
|
||||
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
|
||||
of $$BODY))
|
||||
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
|
||||
of $$BASE))
|
||||
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY))
|
||||
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE))
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
@@ -1665,10 +1658,8 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(GETDUMMYVAR))
|
||||
'(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END
|
||||
declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END)
|
||||
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
|
||||
of $$BODY))
|
||||
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
|
||||
of $$BASE))
|
||||
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY))
|
||||
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE))
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
@@ -1682,12 +1673,9 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(GETDUMMYVAR))
|
||||
'(bind $$BODY _ BODY $$END $$OFFSET $$BASE
|
||||
declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE)
|
||||
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
|
||||
of $$BODY)))
|
||||
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY
|
||||
))
|
||||
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP
|
||||
LENGTH)
|
||||
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) of $$BODY)))
|
||||
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY))
|
||||
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH)
|
||||
of $$BODY)))
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
@@ -1703,11 +1691,9 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
'(bind $$BODY _ BODY $$END $$OFFSET $$BASE
|
||||
declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE)
|
||||
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
|
||||
of $$BODY)))
|
||||
(SETQ $$BASE (ffetch (STRINGP BASE) of
|
||||
$$BODY))
|
||||
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP
|
||||
LENGTH)
|
||||
of $$BODY)))
|
||||
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY))
|
||||
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH)
|
||||
of $$BODY)))
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
@@ -1717,20 +1703,20 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \CHARCODEP DMACRO (OPENLAMBDA (X) (* ;
|
||||
"used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses")
|
||||
(AND (SMALLP X)
|
||||
(IGEQ X 0))))
|
||||
(PUTPROPS \CHARCODEP DMACRO (OPENLAMBDA (X) (* ;
|
||||
"used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses")
|
||||
(AND (SMALLP X)
|
||||
(IGEQ X 0))))
|
||||
|
||||
(PUTPROPS \FATCHARCODEP DMACRO (OPENLAMBDA (X) (* ;
|
||||
"Used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses")
|
||||
(AND (SMALLP X)
|
||||
(IGREATERP X \MAXTHINCHAR))))
|
||||
(PUTPROPS \FATCHARCODEP DMACRO (OPENLAMBDA (X) (* ;
|
||||
"Used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses")
|
||||
(AND (SMALLP X)
|
||||
(IGREATERP X \MAXTHINCHAR))))
|
||||
|
||||
(PUTPROPS \THINCHARCODEP DMACRO (OPENLAMBDA (X)
|
||||
(AND (SMALLP X)
|
||||
(IGEQ X 0)
|
||||
(ILEQ X \MAXTHINCHAR))))
|
||||
(AND (SMALLP X)
|
||||
(IGEQ X 0)
|
||||
(ILEQ X \MAXTHINCHAR))))
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
@@ -1745,22 +1731,22 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \PUTBASECHAR MACRO [OPENLAMBDA (FATP BASE OFFSET CODE)
|
||||
(COND
|
||||
(FATP (\PUTBASEFAT BASE OFFSET CODE))
|
||||
(T (\PUTBASETHIN BASE OFFSET CODE])
|
||||
(COND
|
||||
(FATP (\PUTBASEFAT BASE OFFSET CODE))
|
||||
(T (\PUTBASETHIN BASE OFFSET CODE])
|
||||
|
||||
(PUTPROPS \GETBASECHAR MACRO [(FATP BASE N)
|
||||
(COND
|
||||
(FATP (\GETBASEFAT BASE N))
|
||||
(T (\GETBASETHIN BASE N])
|
||||
(COND
|
||||
(FATP (\GETBASEFAT BASE N))
|
||||
(T (\GETBASETHIN BASE N])
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \CHARSET MACRO ((CHARCODE)
|
||||
(LRSH CHARCODE 8)))
|
||||
(LRSH CHARCODE 8)))
|
||||
|
||||
(PUTPROPS \CHAR8CODE MACRO ((CHARCODE)
|
||||
(LOGAND CHARCODE 255)))
|
||||
(LOGAND CHARCODE 255)))
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
@@ -1787,10 +1773,10 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \NATOMCHARS DMACRO ((AT)
|
||||
(fetch (LITATOM PNAMELENGTH) of AT)))
|
||||
(fetch (LITATOM PNAMELENGTH) of AT)))
|
||||
|
||||
(PUTPROPS \NSTRINGCHARS DMACRO ((S)
|
||||
(fetch (STRINGP LENGTH) of S)))
|
||||
(fetch (STRINGP LENGTH) of S)))
|
||||
)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
@@ -1866,10 +1852,10 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(ADDTOVAR INEWCOMS (FNS ALLOCSTRING %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY))
|
||||
|
||||
(ADDTOVAR INEWCOMS (FILES (SYSLOAD FROM VALUEOF DIRECTORIES)
|
||||
CMLARRAY-SUPPORT))
|
||||
CMLARRAY-SUPPORT))
|
||||
|
||||
(ADDTOVAR EXPANDMACROFNS \PUTBASETHIN \PUTBASEFAT \CHARCODEP \GETBASECHAR \GETBASETHIN
|
||||
\GETBASEFAT \PUTBASECHAR)
|
||||
(ADDTOVAR EXPANDMACROFNS \PUTBASETHIN \PUTBASEFAT \CHARCODEP \GETBASECHAR \GETBASETHIN \GETBASEFAT
|
||||
\PUTBASECHAR)
|
||||
|
||||
(ADDTOVAR DONTCOMPILEFNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY)
|
||||
)
|
||||
@@ -1889,16 +1875,16 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(PUTPROPS LLCHAR COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1994
|
||||
2018 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3970 73876 (ALLOCSTRING 3980 . 6003) (MKATOM 6005 . 6640) (SUBATOM 6642 . 8512) (
|
||||
CHARACTER 8514 . 9518) (\PARSE.NUMBER 9520 . 25240) (\INVALID.DOTTED.SYMBOL 25242 . 25737) (
|
||||
\INVALID.INTEGER 25739 . 27191) (\MKINTEGER 27193 . 29900) (MKSTRING 29902 . 32045) (
|
||||
\PRINDATUM.TO.STRING 32047 . 38225) (BKSYSBUF 38227 . 39761) (NCHARS 39763 . 41463) (NTHCHARCODE 41465
|
||||
. 43511) (RPLCHARCODE 43513 . 44574) (\RPLCHARCODE 44576 . 46111) (NTHCHAR 46113 . 46306) (RPLSTRING
|
||||
46308 . 49519) (SUBSTRING 49521 . 52444) (GNC 52446 . 52619) (GNCCODE 52621 . 53389) (GLC 53391 .
|
||||
53564) (GLCCODE 53566 . 54331) (STREQUAL 54333 . 56447) (STRING.EQUAL 56449 . 60507) (STRINGP 60509 .
|
||||
60660) (CHCON1 60662 . 61449) (U-CASE 61451 . 64678) (L-CASE 64680 . 68540) (U-CASEP 68542 . 69116) (
|
||||
\SMASHABLESTRING 69118 . 69580) (\MAKEWRITABLESTRING 69582 . 70018) (\SMASHSTRING 70020 . 73726) (
|
||||
\FATTENSTRING 73728 . 73874)) (74061 79223 (\GETBASESTRING 74071 . 74725) (\PUTBASESTRING 74727 .
|
||||
77466) (\PUTBASESTRINGFAT 77468 . 78214) (GetBcplString 78216 . 78881) (SetBcplString 78883 . 79221))
|
||||
(104450 107264 (%%COPY-ONED-ARRAY 104460 . 106310) (%%COPY-STRING-TO-ARRAY 106312 . 107262)))))
|
||||
(FILEMAP (NIL (4009 74195 (ALLOCSTRING 4019 . 6042) (MKATOM 6044 . 6679) (SUBATOM 6681 . 8551) (
|
||||
CHARACTER 8553 . 9557) (\PARSE.NUMBER 9559 . 25279) (\INVALID.DOTTED.SYMBOL 25281 . 25776) (
|
||||
\INVALID.INTEGER 25778 . 27230) (\MKINTEGER 27232 . 29939) (MKSTRING 29941 . 32084) (
|
||||
\PRINDATUM.TO.STRING 32086 . 38264) (BKSYSBUF 38266 . 39800) (NCHARS 39802 . 41502) (NTHCHARCODE 41504
|
||||
. 43550) (RPLCHARCODE 43552 . 44613) (\RPLCHARCODE 44615 . 46150) (NTHCHAR 46152 . 46345) (RPLSTRING
|
||||
46347 . 49558) (SUBSTRING 49560 . 52483) (GNC 52485 . 52658) (GNCCODE 52660 . 53428) (GLC 53430 .
|
||||
53603) (GLCCODE 53605 . 54370) (STREQUAL 54372 . 56486) (STRING.EQUAL 56488 . 60826) (STRINGP 60828 .
|
||||
60979) (CHCON1 60981 . 61768) (U-CASE 61770 . 64997) (L-CASE 64999 . 68859) (U-CASEP 68861 . 69435) (
|
||||
\SMASHABLESTRING 69437 . 69899) (\MAKEWRITABLESTRING 69901 . 70337) (\SMASHSTRING 70339 . 74045) (
|
||||
\FATTENSTRING 74047 . 74193)) (74380 79542 (\GETBASESTRING 74390 . 75044) (\PUTBASESTRING 75046 .
|
||||
77785) (\PUTBASESTRINGFAT 77787 . 78533) (GetBcplString 78535 . 79200) (SetBcplString 79202 . 79540))
|
||||
(102859 105673 (%%COPY-ONED-ARRAY 102869 . 104719) (%%COPY-STRING-TO-ARRAY 104721 . 105671)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user