github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-05-05 15:44:25 +00:00
Code Issues Projects Releases Wiki Activity

LLCHAR: Expose interation variables fo I.S.OPRS instring inpname...

Browse Source 
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
2022-04-24 13:46:57 -07:00
parent 3a4852cf8b
commit 74a43b9dea
2 changed files with 88 additions and 108 deletions
Download Patch File Download Diff File Expand all files Collapse all files

196
sources/LLCHAR
View File

@@ -1,11 +1,11 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (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" :PREVIOUS-DATE "23-Apr-2022 07:49:25"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;6) {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)) (CONSTANTS (\FATPNAMESTRINGP T))
(MACROS \PNAMESTRINGPUTCHAR) (MACROS \PNAMESTRINGPUTCHAR)
(OPTIMIZERS FCHARACTER) (OPTIMIZERS FCHARACTER)
(* ;; "Iterators expose control variables, $$OFFSET corresponds to current character (except inside user's repeatwhile or repeatuntil)")
(I.S.OPRS inpname inatom instring) (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")
@@ -1557,24 +1560,19 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
,NUM)) ,NUM))
(DECLARE%: EVAL@COMPILE (DECLARE%: EVAL@COMPILE
(I.S.OPR 'inpname NIL '[SUBPAIR '($$END $$BODY $$FATP $$BASE $$OFFSET) (I.S.OPR 'inpname NIL '[SUBST (GETDUMMYVAR)
(LIST (GETDUMMYVAR) '$$BODY
(GETDUMMYVAR) `(bind $$OFFSET _ 1 $$BODY _ BODY $$BASE $$END $$FATP
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR))
`(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP
declare (LOCALVARS $$END $$BODY $$FATP $$BASE $$OFFSET) declare (LOCALVARS $$END $$BODY $$FATP $$BASE $$OFFSET)
first [PROG NIL first [PROG NIL
$$RETRY $$RETRY
(COND (COND
((STRINGP $$BODY) ((STRINGP $$BODY)
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY)) (SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY))
(SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) (SETQ $$OFFSET (ffetch (STRINGP OFFST) of $$BODY))
of $$BODY))) (SETQ $$END (IPLUS $$OFFSET -1 (ffetch (STRINGP
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH LENGTH)
) of $$BODY)))
of $$BODY)))
(SETQ $$FATP (ffetch (STRINGP FATSTRINGP) (SETQ $$FATP (ffetch (STRINGP FATSTRINGP)
of $$BODY))) of $$BODY)))
((LITATOM $$BODY) ((LITATOM $$BODY)
@@ -1585,120 +1583,102 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
(SETQ $$FATP (ffetch (LITATOM FATPNAMEP) (SETQ $$FATP (ffetch (LITATOM FATPNAMEP)
of $$BODY))) of $$BODY)))
(T (SETQ $$BODY (MKSTRING $$BODY)) (T (SETQ $$BODY (MKSTRING $$BODY))
(GO $$RETRY] (GO $$RETRY] eachtime (AND (IGREATERP $$OFFSET
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) $$END)
(AND (IGREATERP $$OFFSET $$END) (GO $$OUT))
(GO $$OUT)) (SETQ I.V.
(SETQ I.V. (COND (\GETBASECHAR $$FATP $$BASE
($$FATP (\GETBASEFAT $$BASE $$OFFSET)) $$OFFSET))
(T (\GETBASETHIN $$BASE $$OFFSET] repeatwhile (PROGN (SETQ $$OFFSET (ADD1 $$OFFSET))
T]
T) T)
(I.S.OPR 'inatom NIL '[SUBPAIR '($$OFFSET $$BODY $$BASE $$END $$FATP) (I.S.OPR 'inatom NIL '[SUBST (GETDUMMYVAR)
(LIST (GETDUMMYVAR) '$$BODY
(GETDUMMYVAR) '(bind $$OFFSET _ 1 $$BODY _ BODY $$BASE $$END $$FATP
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR))
'(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP
declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END $$FATP) declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END $$FATP)
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY)) first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY))
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE)) (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE))
(SETQ $$FATP (ffetch (LITATOM FATPNAMEP) of $$BODY)) (SETQ $$FATP (ffetch (LITATOM FATPNAMEP) of $$BODY))
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) eachtime (AND (IGREATERP $$OFFSET $$END)
(AND (IGREATERP $$OFFSET $$END) (GO $$OUT))
(GO $$OUT)) (SETQ I.V. (\GETBASECHAR $$FATP $$BASE $$OFFSET))
(SETQ I.V. (COND repeatwhile (PROGN (SETQ $$OFFSET (ADD1 $$OFFSET))
($$FATP (\GETBASEFAT $$BASE $$OFFSET)) T]
(T (\GETBASETHIN $$BASE $$OFFSET]
T) T)
(I.S.OPR 'instring NIL '[SUBPAIR '($$BODY $$END $$OFFSET $$BASE $$FATP) (I.S.OPR 'instring NIL '[SUBST (GETDUMMYVAR)
(LIST (GETDUMMYVAR) '$$BODY
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR))
'(bind $$BODY _ BODY $$END $$OFFSET $$BASE $$FATP '(bind $$BODY _ BODY $$END $$OFFSET $$BASE $$FATP
declare (LOCALVARS $$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 $$BASE (ffetch (STRINGP BASE) of $$BODY))
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH) (SETQ $$END (IPLUS $$OFFSET -1 (ffetch (STRINGP LENGTH)
of $$BODY))) of $$BODY)))
(SETQ $$FATP (ffetch (STRINGP FATSTRINGP) of $$BODY)) (SETQ $$FATP (ffetch (STRINGP FATSTRINGP) of $$BODY))
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) eachtime (AND (IGREATERP $$OFFSET $$END)
(AND (IGREATERP $$OFFSET $$END) (GO $$OUT))
(GO $$OUT)) (SETQ I.V. (\GETBASECHAR $$FATP $$BASE $$OFFSET))
(SETQ I.V. (COND repeatwhile (PROGN (SETQ $$OFFSET (ADD1 $$OFFSET))
($$FATP (\GETBASEFAT $$BASE $$OFFSET)) T]
(T (\GETBASETHIN $$BASE $$OFFSET]
T) T)
) )
(DECLARE%: EVAL@COMPILE (DECLARE%: EVAL@COMPILE
(I.S.OPR 'infatatom NIL '[SUBPAIR '($$OFFSET $$BODY $$BASE $$END) (I.S.OPR 'infatatom NIL '[SUBST (GETDUMMYVAR)
(LIST (GETDUMMYVAR) '$$BODY
(GETDUMMYVAR) '(bind $$OFFSET _ 1 $$BODY _ BODY $$BASE $$END
(GETDUMMYVAR)
(GETDUMMYVAR))
'(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END
declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END) declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END)
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY)) first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY))
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE)) (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE))
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) eachtime (AND (IGREATERP $$OFFSET $$END)
(AND (IGREATERP $$OFFSET $$END) (GO $$OUT))
(GO $$OUT)) (SETQ I.V. (\GETBASEFAT $$BASE $$OFFSET))
(SETQ I.V. (\GETBASEFAT $$BASE $$OFFSET] repeatwhile (PROGN (SETQ $$OFFSET (ADD1 $$OFFSET))
T]
T) T)
(I.S.OPR 'inthinatom NIL '[SUBPAIR '($$OFFSET $$BODY $$BASE $$END) (I.S.OPR 'inthinatom NIL '[SUBST (GETDUMMYVAR)
(LIST (GETDUMMYVAR) '$$BODY
(GETDUMMYVAR) '(bind $$OFFSET _ 1 $$BODY _ BODY $$BASE $$END
(GETDUMMYVAR)
(GETDUMMYVAR))
'(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END
declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END) declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END)
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY)) first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY))
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE)) (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE))
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) eachtime (AND (IGREATERP $$OFFSET $$END)
(AND (IGREATERP $$OFFSET $$END) (GO $$OUT))
(GO $$OUT)) (SETQ I.V. (\GETBASETHIN $$BASE $$OFFSET))
(SETQ I.V. (\GETBASETHIN $$BASE $$OFFSET] repeatwhile (PROGN (SETQ $$OFFSET (ADD1 $$OFFSET))
T]
T) T)
(I.S.OPR 'infatstring NIL '[SUBPAIR '($$BODY $$END $$OFFSET $$BASE) (I.S.OPR 'infatstring NIL '[SUBST (GETDUMMYVAR)
(LIST (GETDUMMYVAR) '$$BODY
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR))
'(bind $$BODY _ BODY $$END $$OFFSET $$BASE '(bind $$BODY _ BODY $$END $$OFFSET $$BASE
declare (LOCALVARS $$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 $$BASE (ffetch (STRINGP BASE) of $$BODY))
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH) (SETQ $$END (IPLUS $$OFFSET -1 (ffetch (STRINGP LENGTH)
of $$BODY))) of $$BODY)))
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) eachtime (AND (IGREATERP $$OFFSET $$END)
(AND (IGREATERP $$OFFSET $$END) (GO $$OUT))
(GO $$OUT)) (SETQ I.V. (\GETBASEFAT $$BASE $$OFFSET))
(SETQ I.V. (\GETBASEFAT $$BASE $$OFFSET] repeatwhile (PROGN (SETQ $$OFFSET (ADD1 $$OFFSET))
T]
T) T)
(I.S.OPR 'inthinstring NIL '[SUBPAIR '($$BODY $$END $$OFFSET $$BASE) (I.S.OPR 'inthinstring NIL '[SUBST (GETDUMMYVAR)
(LIST (GETDUMMYVAR) '$$BODY
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR))
'(bind $$BODY _ BODY $$END $$OFFSET $$BASE '(bind $$BODY _ BODY $$END $$OFFSET $$BASE
declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE) declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE)
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) first (SETQ $$OFFSET (ffetch (STRINGP OFFST) of $$BODY))
of $$BODY)))
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY)) (SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY))
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH) (SETQ $$END (IPLUS $$OFFSET -1 (ffetch (STRINGP LENGTH)
of $$BODY))) of $$BODY)))
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) eachtime (AND (IGREATERP $$OFFSET $$END)
(AND (IGREATERP $$OFFSET $$END) (GO $$OUT))
(GO $$OUT)) (SETQ I.V. (\GETBASETHIN $$BASE $$OFFSET))
(SETQ I.V. (\GETBASETHIN $$BASE $$OFFSET] repeatwhile (PROGN (SETQ $$OFFSET (ADD1 $$OFFSET))
T]
T) T)
) )
(DECLARE%: EVAL@COMPILE (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 (PUTPROPS LLCHAR COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1994
2018 2021)) 2018 2021))
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (4009 74195 (ALLOCSTRING 4019 . 6042) (MKATOM 6044 . 6679) (SUBATOM 6681 . 8551) ( (FILEMAP (NIL (4223 74409 (ALLOCSTRING 4233 . 6256) (MKATOM 6258 . 6893) (SUBATOM 6895 . 8765) (
CHARACTER 8553 . 9557) (\PARSE.NUMBER 9559 . 25279) (\INVALID.DOTTED.SYMBOL 25281 . 25776) ( CHARACTER 8767 . 9771) (\PARSE.NUMBER 9773 . 25493) (\INVALID.DOTTED.SYMBOL 25495 . 25990) (
\INVALID.INTEGER 25778 . 27230) (\MKINTEGER 27232 . 29939) (MKSTRING 29941 . 32084) ( \INVALID.INTEGER 25992 . 27444) (\MKINTEGER 27446 . 30153) (MKSTRING 30155 . 32298) (
\PRINDATUM.TO.STRING 32086 . 38264) (BKSYSBUF 38266 . 39800) (NCHARS 39802 . 41502) (NTHCHARCODE 41504 \PRINDATUM.TO.STRING 32300 . 38478) (BKSYSBUF 38480 . 40014) (NCHARS 40016 . 41716) (NTHCHARCODE 41718
. 43550) (RPLCHARCODE 43552 . 44613) (\RPLCHARCODE 44615 . 46150) (NTHCHAR 46152 . 46345) (RPLSTRING . 43764) (RPLCHARCODE 43766 . 44827) (\RPLCHARCODE 44829 . 46364) (NTHCHAR 46366 . 46559) (RPLSTRING
46347 . 49558) (SUBSTRING 49560 . 52483) (GNC 52485 . 52658) (GNCCODE 52660 . 53428) (GLC 53430 . 46561 . 49772) (SUBSTRING 49774 . 52697) (GNC 52699 . 52872) (GNCCODE 52874 . 53642) (GLC 53644 .
53603) (GLCCODE 53605 . 54370) (STREQUAL 54372 . 56486) (STRING.EQUAL 56488 . 60826) (STRINGP 60828 . 53817) (GLCCODE 53819 . 54584) (STREQUAL 54586 . 56700) (STRING.EQUAL 56702 . 61040) (STRINGP 61042 .
60979) (CHCON1 60981 . 61768) (U-CASE 61770 . 64997) (L-CASE 64999 . 68859) (U-CASEP 68861 . 69435) ( 61193) (CHCON1 61195 . 61982) (U-CASE 61984 . 65211) (L-CASE 65213 . 69073) (U-CASEP 69075 . 69649) (
\SMASHABLESTRING 69437 . 69899) (\MAKEWRITABLESTRING 69901 . 70337) (\SMASHSTRING 70339 . 74045) ( \SMASHABLESTRING 69651 . 70113) (\MAKEWRITABLESTRING 70115 . 70551) (\SMASHSTRING 70553 . 74259) (
\FATTENSTRING 74047 . 74193)) (74380 79542 (\GETBASESTRING 74390 . 75044) (\PUTBASESTRING 75046 . \FATTENSTRING 74261 . 74407)) (74594 79756 (\GETBASESTRING 74604 . 75258) (\PUTBASESTRING 75260 .
77785) (\PUTBASESTRINGFAT 77787 . 78533) (GetBcplString 78535 . 79200) (SetBcplString 79202 . 79540)) 77999) (\PUTBASESTRINGFAT 78001 . 78747) (GetBcplString 78749 . 79414) (SetBcplString 79416 . 79754))
(102859 105673 (%%COPY-ONED-ARRAY 102869 . 104719) (%%COPY-STRING-TO-ARRAY 104721 . 105671))))) (101801 104615 (%%COPY-ONED-ARRAY 101811 . 103661) (%%COPY-STRING-TO-ARRAY 103663 . 104613)))))
STOP STOP

BIN
sources/LLCHAR.LCOM
View File

Binary file not shown.