From fe62e8e6e23983ff461e0dc09686cdba76e048c1 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Mon, 24 Jan 2022 21:09:15 -0800 Subject: [PATCH] LLCHAR: Extend STRING.EQUAL to take CASEARRAY as argument still defaults to the previously built-in reference to UPPERCASEARRAY --- sources/LLCHAR | 526 +++++++++++++++++++++----------------------- sources/LLCHAR.LCOM | Bin 22220 -> 22298 bytes 2 files changed, 256 insertions(+), 270 deletions(-) diff --git a/sources/LLCHAR b/sources/LLCHAR index c42762ae..db262b7d 100644 --- a/sources/LLCHAR +++ b/sources/LLCHAR @@ -1,9 +1,11 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "21-Jun-2021 18:08:19"  -{DSK}kaplan>Local>medley3.5>git-medley>sources>LLCHAR.;6 108072 - previous date%: "19-Jun-2021 10:00:42" -{DSK}kaplan>Local>medley3.5>git-medley>sources>LLCHAR.;5) +(FILECREATED " 8-Jan-2022 19:08:41" {DSK}kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;8 106473 + + :CHANGES-TO (FNS STRING.EQUAL) + + :PREVIOUS-DATE "21-Jun-2021 18:08:19" +{DSK}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 diff --git a/sources/LLCHAR.LCOM b/sources/LLCHAR.LCOM index 032a8d9921fe1661488c3a10d025ff063ee7ab13..b2e9905752b99f2c958fbae78c4293b170f93997 100644 GIT binary patch delta 664 zcmah_U2D@&7;f4kt{1`(ET|XnB9-ML;hdbLO|rJ`v^~i((>5lltYa5jO%caFU~|GQ zhA4O|j(``UKf#X~z23d(@9?(%f|*3nfx4ZG_v7Jx-{(2c*SFlOcifAG8>Ly(c39hE zG+-UzK@%6(wnQ1pGGN_6nxWvs_3GozeQ|RfZjASvyW4v^_r|+T$7wH6Pny$&WJ^7@ zr5Q3ZRD}n=-S4`|aWQ2G`4T+X0^S@r4xFBsB#DP`?cq55=N+9F5{Yo0#%P|a+&@Dk zlrX9)H3CMWx@R$84Eiu@_I&UI&+b_gyECAU0EX+ayLNxzi=D&};AJc>?qz;pz*_1D z)}!~_&1?VXs>VOK*ZOrC+SF&%^XL#T3<1HCAV7ZkQZ84B-pqaH9!1aUtlRoLwVF%b zsCXewU-E_ZNxahvSJQ6taddn!Ey`&a6+bM~sjSL>Dm*%w&W zB%3)pImq&HE2=k!+(GoRQRU3&TcdoL5LmGthgsB-sAqv9s}b&9>7W`^Dw$%jZ<;;} zfavHq)Jnbsq=sO{VnN!N_L2)kCD6V7%S0eVi|3nHIfW<$2CmDzKOPWS{|mw@WOT_H Lq{Yu~HOoH%)l{!@ delta 598 zcmbQWj`7S|#t9xu8g8CGuFgTOjv=lt3Q9(Xx?ZJux<&>@h6;ujRt6SUMkW)p&Fa%L zOLTKnQ*u%(?TYhDi;`1|?R96&nOT`wC@F9$Is5wt0FBoL z*^#28keR2T&wQ;phU;qL(5OIo$IqSpbI1Uh797JpgcjN@oNlaUqn>PM8_H@i) z;Q|SK0P~e6+uLgKP6jL4(4PR3m|STa$vA29Wm_|;Xn(QnEAe9c{Uv~u#D0IN>?<3t zFld+KGK{7^&;;<`(Q4qF@a4E=BR8srRA2R0EXXO1CcXrKU=1R7&t Ky7`X1oj3seE~9Y(