LLCHAR: Expose interation variables fo I.S.OPRS instring inpname...
So can be used (carefully) in more, trickier situations. $$OFFSET also now is the index of the current character
This commit is contained in:
rmkaplan
196
sources/LLCHAR
196
sources/LLCHAR
@@ -1,11 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 8-Jan-2022 19:08:41" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;8 106473
|
||||
(FILECREATED "23-Apr-2022 17:19:02" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;12 105415
|
||||
|
||||
:CHANGES-TO (FNS STRING.EQUAL)
|
||||
:CHANGES-TO (VARS LLCHARCOMS)
|
||||
|
||||
:PREVIOUS-DATE "21-Jun-2021 18:08:19"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;6)
|
||||
:PREVIOUS-DATE "23-Apr-2022 07:49:25"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;11)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -31,6 +31,9 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(CONSTANTS (\FATPNAMESTRINGP T))
|
||||
(MACROS \PNAMESTRINGPUTCHAR)
|
||||
(OPTIMIZERS FCHARACTER)
|
||||
|
||||
(* ;; "Iterators expose control variables, $$OFFSET corresponds to current character (except inside user's repeatwhile or repeatuntil)")
|
||||
|
||||
(I.S.OPRS inpname inatom instring)
|
||||
(* ;
|
||||
"For use when the inner-loop test in the generic operators is too expensive")
|
||||
@@ -1557,24 +1560,19 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
,NUM))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(I.S.OPR 'inpname NIL '[SUBPAIR '($$END $$BODY $$FATP $$BASE $$OFFSET)
|
||||
(LIST (GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR))
|
||||
`(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP
|
||||
(I.S.OPR 'inpname NIL '[SUBST (GETDUMMYVAR)
|
||||
'$$BODY
|
||||
`(bind $$OFFSET _ 1 $$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 $$OFFSET (ffetch (STRINGP OFFST) of $$BODY))
|
||||
(SETQ $$END (IPLUS $$OFFSET -1 (ffetch (STRINGP
|
||||
LENGTH)
|
||||
of $$BODY)))
|
||||
(SETQ $$FATP (ffetch (STRINGP FATSTRINGP)
|
||||
of $$BODY)))
|
||||
((LITATOM $$BODY)
|
||||
@@ -1585,120 +1583,102 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(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))
|
||||
(SETQ I.V. (COND
|
||||
($$FATP (\GETBASEFAT $$BASE $$OFFSET))
|
||||
(T (\GETBASETHIN $$BASE $$OFFSET]
|
||||
(GO $$RETRY] eachtime (AND (IGREATERP $$OFFSET
|
||||
$$END)
|
||||
(GO $$OUT))
|
||||
(SETQ I.V.
|
||||
(\GETBASECHAR $$FATP $$BASE
|
||||
$$OFFSET))
|
||||
repeatwhile (PROGN (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
T]
|
||||
T)
|
||||
|
||||
(I.S.OPR 'inatom NIL '[SUBPAIR '($$OFFSET $$BODY $$BASE $$END $$FATP)
|
||||
(LIST (GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR))
|
||||
'(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP
|
||||
(I.S.OPR 'inatom NIL '[SUBST (GETDUMMYVAR)
|
||||
'$$BODY
|
||||
'(bind $$OFFSET _ 1 $$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))
|
||||
(SETQ $$FATP (ffetch (LITATOM FATPNAMEP) of $$BODY))
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
(SETQ I.V. (COND
|
||||
($$FATP (\GETBASEFAT $$BASE $$OFFSET))
|
||||
(T (\GETBASETHIN $$BASE $$OFFSET]
|
||||
eachtime (AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
(SETQ I.V. (\GETBASECHAR $$FATP $$BASE $$OFFSET))
|
||||
repeatwhile (PROGN (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
T]
|
||||
T)
|
||||
|
||||
(I.S.OPR 'instring NIL '[SUBPAIR '($$BODY $$END $$OFFSET $$BASE $$FATP)
|
||||
(LIST (GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR))
|
||||
(I.S.OPR 'instring NIL '[SUBST (GETDUMMYVAR)
|
||||
'$$BODY
|
||||
'(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 (ffetch (STRINGP OFFST) of $$BODY))
|
||||
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY))
|
||||
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH)
|
||||
of $$BODY)))
|
||||
(SETQ $$END (IPLUS $$OFFSET -1 (ffetch (STRINGP LENGTH)
|
||||
of $$BODY)))
|
||||
(SETQ $$FATP (ffetch (STRINGP FATSTRINGP) of $$BODY))
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
(SETQ I.V. (COND
|
||||
($$FATP (\GETBASEFAT $$BASE $$OFFSET))
|
||||
(T (\GETBASETHIN $$BASE $$OFFSET]
|
||||
eachtime (AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
(SETQ I.V. (\GETBASECHAR $$FATP $$BASE $$OFFSET))
|
||||
repeatwhile (PROGN (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
T]
|
||||
T)
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(I.S.OPR 'infatatom NIL '[SUBPAIR '($$OFFSET $$BODY $$BASE $$END)
|
||||
(LIST (GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR))
|
||||
'(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END
|
||||
(I.S.OPR 'infatatom NIL '[SUBST (GETDUMMYVAR)
|
||||
'$$BODY
|
||||
'(bind $$OFFSET _ 1 $$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))
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
(SETQ I.V. (\GETBASEFAT $$BASE $$OFFSET]
|
||||
eachtime (AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
(SETQ I.V. (\GETBASEFAT $$BASE $$OFFSET))
|
||||
repeatwhile (PROGN (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
T]
|
||||
T)
|
||||
|
||||
(I.S.OPR 'inthinatom NIL '[SUBPAIR '($$OFFSET $$BODY $$BASE $$END)
|
||||
(LIST (GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR))
|
||||
'(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END
|
||||
(I.S.OPR 'inthinatom NIL '[SUBST (GETDUMMYVAR)
|
||||
'$$BODY
|
||||
'(bind $$OFFSET _ 1 $$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))
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
(SETQ I.V. (\GETBASETHIN $$BASE $$OFFSET]
|
||||
eachtime (AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
(SETQ I.V. (\GETBASETHIN $$BASE $$OFFSET))
|
||||
repeatwhile (PROGN (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
T]
|
||||
T)
|
||||
|
||||
(I.S.OPR 'infatstring NIL '[SUBPAIR '($$BODY $$END $$OFFSET $$BASE)
|
||||
(LIST (GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR))
|
||||
(I.S.OPR 'infatstring NIL '[SUBST (GETDUMMYVAR)
|
||||
'$$BODY
|
||||
'(bind $$BODY _ BODY $$END $$OFFSET $$BASE
|
||||
declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE)
|
||||
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) of $$BODY)))
|
||||
first (SETQ $$OFFSET (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)
|
||||
(GO $$OUT))
|
||||
(SETQ I.V. (\GETBASEFAT $$BASE $$OFFSET]
|
||||
(SETQ $$END (IPLUS $$OFFSET -1 (ffetch (STRINGP LENGTH)
|
||||
of $$BODY)))
|
||||
eachtime (AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
(SETQ I.V. (\GETBASEFAT $$BASE $$OFFSET))
|
||||
repeatwhile (PROGN (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
T]
|
||||
T)
|
||||
|
||||
(I.S.OPR 'inthinstring NIL '[SUBPAIR '($$BODY $$END $$OFFSET $$BASE)
|
||||
(LIST (GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR)
|
||||
(GETDUMMYVAR))
|
||||
(I.S.OPR 'inthinstring NIL '[SUBST (GETDUMMYVAR)
|
||||
'$$BODY
|
||||
'(bind $$BODY _ BODY $$END $$OFFSET $$BASE
|
||||
declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE)
|
||||
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
|
||||
of $$BODY)))
|
||||
first (SETQ $$OFFSET (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)
|
||||
(GO $$OUT))
|
||||
(SETQ I.V. (\GETBASETHIN $$BASE $$OFFSET]
|
||||
(SETQ $$END (IPLUS $$OFFSET -1 (ffetch (STRINGP LENGTH)
|
||||
of $$BODY)))
|
||||
eachtime (AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
(SETQ I.V. (\GETBASETHIN $$BASE $$OFFSET))
|
||||
repeatwhile (PROGN (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
T]
|
||||
T)
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
@@ -1875,16 +1855,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 (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)))))
|
||||
(FILEMAP (NIL (4223 74409 (ALLOCSTRING 4233 . 6256) (MKATOM 6258 . 6893) (SUBATOM 6895 . 8765) (
|
||||
CHARACTER 8767 . 9771) (\PARSE.NUMBER 9773 . 25493) (\INVALID.DOTTED.SYMBOL 25495 . 25990) (
|
||||
\INVALID.INTEGER 25992 . 27444) (\MKINTEGER 27446 . 30153) (MKSTRING 30155 . 32298) (
|
||||
\PRINDATUM.TO.STRING 32300 . 38478) (BKSYSBUF 38480 . 40014) (NCHARS 40016 . 41716) (NTHCHARCODE 41718
|
||||
. 43764) (RPLCHARCODE 43766 . 44827) (\RPLCHARCODE 44829 . 46364) (NTHCHAR 46366 . 46559) (RPLSTRING
|
||||
46561 . 49772) (SUBSTRING 49774 . 52697) (GNC 52699 . 52872) (GNCCODE 52874 . 53642) (GLC 53644 .
|
||||
53817) (GLCCODE 53819 . 54584) (STREQUAL 54586 . 56700) (STRING.EQUAL 56702 . 61040) (STRINGP 61042 .
|
||||
61193) (CHCON1 61195 . 61982) (U-CASE 61984 . 65211) (L-CASE 65213 . 69073) (U-CASEP 69075 . 69649) (
|
||||
\SMASHABLESTRING 69651 . 70113) (\MAKEWRITABLESTRING 70115 . 70551) (\SMASHSTRING 70553 . 74259) (
|
||||
\FATTENSTRING 74261 . 74407)) (74594 79756 (\GETBASESTRING 74604 . 75258) (\PUTBASESTRING 75260 .
|
||||
77999) (\PUTBASESTRINGFAT 78001 . 78747) (GetBcplString 78749 . 79414) (SetBcplString 79416 . 79754))
|
||||
(101801 104615 (%%COPY-ONED-ARRAY 101811 . 103661) (%%COPY-STRING-TO-ARRAY 103663 . 104613)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user