(FILECREATED "12-Mar-84 20:29:21" {PHYLUM}<LISP>LIBRARY>BSEARCH.;7 11482
changes to: (FNS STRPOS)
previous date: " 9-Mar-84 19:17:19" {PHYLUM}<LISP>LIBRARY>BSEARCH.;6)
(* Copyright (c) 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT BSEARCHCOMS)
(RPAQQ BSEARCHCOMS ((FNS STRPOS STRPOSL BFILEPOS)
(GLOBALRESOURCES (\STRPOSLARRAY (NCREATE (QUOTE CHARTABLE))))
(VARS \BFILEPOS.SHORTPATTERNL)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD? (QUOTE STRPOS)
(QUOTE BSTRPOS))
(MOVD? (QUOTE STRPOSL)
(QUOTE BSTRPOSL))))))
(DEFINEQ
(STRPOS
(LAMBDA (PAT STRING START SKIP ANCHOR TAIL CASEARRAY BACKWARDSFLG)
(* JonL "12-Mar-84 20:26")
(DECLARE (GLOBALVARS \TRANSPARENT))
(PROG (PATLEN PATBASE PATOFFST STRINGLEN STRINGBASE STRINGOFFST MAXI JMAX 1stPATchar jthPATchar)
(if (LITATOM PAT)
then (SETQ PATBASE (fetch (LITATOM PNAMEBASE) of PAT))
(SETQ PATOFFST 1)
(SETQ PATLEN (fetch (LITATOM PNAMELENGTH) of PAT))
else (OR (STRINGP PAT)
(SETQ PAT (MKSTRING PAT)))
(SETQ PATBASE (fetch (STRINGP BASE) of PAT))
(SETQ PATOFFST (fetch (STRINGP OFFST) of PAT))
(SETQ PATLEN (fetch (STRINGP LENGTH) of PAT)))
(if (LITATOM STRING)
then (SETQ STRINGBASE (fetch (LITATOM PNAMEBASE) of STRING))
(SETQ STRINGOFFST 1)
(SETQ STRINGLEN (fetch (LITATOM PNAMELENGTH) of STRING))
else (OR (STRINGP STRING)
(SETQ STRING (MKSTRING STRING)))
(SETQ STRINGBASE (fetch (STRINGP BASE) of STRING))
(SETQ STRINGOFFST (fetch (STRINGP OFFST) of STRING))
(SETQ STRINGLEN (fetch (STRINGP LENGTH) of STRING)))
(if (IGEQ 0 (SETQ MAXI (ADD1 (IDIFFERENCE STRINGLEN PATLEN))))
then (* Who's he kidding? The PATTERN length is greater than
the STRING length)
(RETURN))
(if (NULL START)
then (SETQ START (if BACKWARDSFLG
then MAXI
else 1))
elseif (ILESSP START 0)
then (add START (ADD1 STRINGLEN))
(if (ILESSP START 1)
then (RETURN))
elseif (IGREATERP START MAXI)
then (RETURN)) (* Normalize start to a 1-origin index between 1 and
LEN)
(if (ILEQ PATLEN 0)
then (RETURN START)) (* Null pattern matches anything)
(AND SKIP (SETQ SKIP (CHCON1 SKIP)))
(if (NULL CASEARRAY)
then (SETQ CASEARRAY \TRANSPARENT)
elseif (NOT (AND (ARRAYP CASEARRAY)
(EQ \ST.BYTE (fetch (ARRAYP TYP) of CASEARRAY))
(EQ (CONSTANT (EXPT 2 BITSPERBYTE))
(fetch (ARRAYP LENGTH) of CASEARRAY))))
then (\ILLEGAL.ARG CASEARRAY)) (* Oh, for a LET here!)
(add STRINGOFFST -1)
(add PATOFFST -1)
(RETURN (PROG ((CAOFFST (fetch (ARRAYP OFFST) of CASEARRAY))
(CABASE (fetch (ARRAYP BASE) of CASEARRAY))
(OFFST.I (IPLUS STRINGOFFST START (if BACKWARDSFLG
then 1
else -1)))
(LASTI (IPLUS STRINGOFFST
(if ANCHOR
then START
elseif BACKWARDSFLG
then 1
else MAXI)))
(JSTART (IPLUS PATOFFST 2))
(JMAX (IPLUS PATOFFST PATLEN))) (* Remember! START is a 1-origin index)
(* There will be at least one pass thru the following
loop, or else we would have (RETURN) before now)
(OR (ZEROP CAOFFST)
(SHOULDNT "NonZero OFFST for a CASEARRAY?"))
(SETQ 1stPATchar (\GETBASEBYTE CABASE (\GETBASEBYTE PATBASE (ADD1 PATOFFST))))
LP (if (if BACKWARDSFLG
then (ILESSP (add OFFST.I -1)
LASTI)
else (IGREATERP (add OFFST.I 1)
LASTI))
then (RETURN)
elseif (AND (OR (EQ 1stPATchar SKIP)
(EQ 1stPATchar (\GETBASEBYTE CABASE (\GETBASEBYTE
STRINGBASE
OFFST.I))))
(for J from JSTART to JMAX as K from (ADD1 OFFST.I)
always (OR (EQ SKIP (SETQ jthPATchar
(\GETBASEBYTE CABASE (\GETBASEBYTE PATBASE
J))))
(EQ jthPATchar (\GETBASEBYTE CABASE
(\GETBASEBYTE
STRINGBASE K)))
)))
then (RETURN (IDIFFERENCE (if TAIL
then (IPLUS OFFST.I PATLEN)
else OFFST.I)
STRINGOFFST)))
(GO LP) (* Fall out thru bottom if didn't find it)
)))))
(STRPOSL
(LAMBDA (A STRING START NEG CASEARRAY BACKWARDSFLG) (* JonL " 8-Mar-84 14:33")
(GLOBALRESOURCE \STRPOSLARRAY (PROG (BASE OFFST LEN I LASTI)
(OR (type? CHARTABLE A)
(SETQ A (MAKEBITTABLE A NIL \STRPOSLARRAY)))
(if (LITATOM STRING)
then (SETQ BASE (fetch (LITATOM PNAMEBASE) of STRING))
(SETQ LEN (fetch (LITATOM PNAMELENGTH) of STRING))
(SETQ OFFST 1)
else (OR (STRINGP STRING)
(SETQ STRING (MKSTRING STRING)))
(SETQ BASE (fetch (STRINGP BASE) of STRING))
(SETQ LEN (fetch (STRINGP LENGTH) of STRING))
(SETQ OFFST (fetch (STRINGP OFFST) of STRING)))
(if (NULL START)
then (SETQ START (if BACKWARDSFLG
then LEN
else 1))
elseif (ILESSP START 0)
then (add START (ADD1 LEN))
(if (ILESSP START 1)
then (RETURN))
elseif (IGREATERP START LEN)
then (RETURN)) (* Normalize start to a 1-origin index between 1 and
LEN)
(add OFFST -1) (* Bias the OFFST since START is 1-origin and the loop
deals in 0-origin)
(SETQ NEG (if NEG
then
(* Convert NEG to match the correct value returned by
\SYNCODE)
0
else 1))
(if (NULL CASEARRAY)
then (SETQ CASEARRAY \TRANSPARENT)
elseif (NOT (AND (ARRAYP CASEARRAY)
(EQ \ST.BYTE (fetch (ARRAYP TYP)
of CASEARRAY))
(EQ (CONSTANT (EXPT 2 BITSPERBYTE))
(fetch (ARRAYP LENGTH) of CASEARRAY))))
then (\ILLEGAL.ARG CASEARRAY))
(SETQ I (IPLUS OFFST START))
(SETQ LASTI (IPLUS OFFST (if BACKWARDSFLG
then (add I 1)
1
else (add I -1)
LEN)))
(OR (ZEROP (fetch (ARRAYP OFFST) of CASEARRAY))
(SHOULDNT "NonZero OFFST for CASEARRAY?"))
(SETQ CASEARRAY (fetch (ARRAYP BASE) of CASEARRAY))
(* There will be at least one pass thru the following
loop, or else we would have (RETURN) before now)
LP (if (if BACKWARDSFLG
then (ILESSP (add I -1)
LASTI)
else (IGREATERP (add I 1)
LASTI))
then (RETURN)
elseif (EQ NEG (\SYNCODE A (\GETBASEBYTE CASEARRAY
(\GETBASEBYTE
BASE I))))
then (RETURN (IDIFFERENCE I OFFST)))
(GO LP)))))
(BFILEPOS
(LAMBDA (PATTERN FILE LOWINDEX HIGHINDEX SKIP TAIL CASEARRAY)
(* JonL " 1-Jan-84 02:34")
(OR (STRINGP PATTERN)
(LITATOM PATTERN)
(SETQ PATTERN (MKSTRING PATTERN)))
(RESETLST (PROG ((PLEN (NCHARS PATTERN))
(INCREMENT 128)
(FF (FUNCTION FILEPOS))
(OFPOS 0)
ORIGINALLYOPENP FLEN QUARTERFLEN STARTI NEXTI MAXI TEM STRM)
(if (SETQ TEM (OPENP FILE))
then (SETQ ORIGINALLYOPENP T)
(SETQ STRM (\GETSTREAM TEM))
else (RESETSAVE (SETQ STRM (OPENSTREAM FILE (QUOTE INPUT)))
(QUOTE (PROGN (CLOSEF? OLDVALUE)))))
(SETQ FLEN (GETFILEINFO STRM (QUOTE LENGTH)))
(if (IGREATERP 0 (SETQ MAXI (IDIFFERENCE FLEN PLEN)))
then (* Who's he kidding? The PATTERN length is greater than
the file length)
(RETURN))
(SETQ QUARTERFLEN (IMAX 2 (LRSH FLEN 2)))
(SETQ OFPOS (GETFILEPTR STRM))
(if (NULL LOWINDEX)
then (SETQ LOWINDEX OFPOS)
elseif (ILESSP LOWINDEX 0)
then (add LOWINDEX (ADD1 MAXI))
(if (ILESSP LOWINDEX 0)
then (SETQ LOWINDEX 0))
elseif (IGREATERP LOWINDEX MAXI)
then (RETURN)) (* Note that LOWINDEX really means low-end limit for
search)
(if (NULL HIGHINDEX)
then (SETQ HIGHINDEX MAX.FIXP)
elseif (ILESSP HIGHINDEX 0)
then (add HIGHINDEX (ADD1 MAXI)))
(SETQ HIGHINDEX (IMIN HIGHINDEX MAXI))
(if (ILESSP HIGHINDEX LOWINDEX)
then (ERROR "High-end index less than low-end"))
(if ORIGINALLYOPENP
then (RESETSAVE (LIST STRM OFPOS)
(QUOTE (AND RESETSTATE (APPLY (QUOTE SETFILEPTR)
OLDVALUE)))))
(SETQ NEXTI)
(SETQ STARTI (ADD1 HIGHINDEX))
(SETQ TAIL (if TAIL
then PLEN
else 0))
FINDFIRST
(if NEXTI
then (SETQ STARTI NEXTI)
elseif (ILEQ STARTI LOWINDEX)
then (* Looks like we never found any instance of the
PATTERN)
(RETURN)
else (SETQ MAXI (SUB1 STARTI))
(SETQ STARTI (IMAX (PROG1 LOWINDEX
(* Comment PPLossage))
(IDIFFERENCE STARTI (if (ILESSP INCREMENT QUARTERFLEN)
then (PROG1 INCREMENT
(SETQ INCREMENT
(LLSH INCREMENT 1)
))
else QUARTERFLEN))))
(SETQ NEXTI (FFILEPOS PATTERN STRM STARTI MAXI SKIP NIL CASEARRAY))
(GO FINDFIRST))
NARROWDOWN (* At this point, we have one instance found at STARTI
and certification that none occur at or beyond MAXI)
(SETQ NEXTI (IPLUS STARTI (LRSH (IDIFFERENCE MAXI STARTI)
1)))
(if (IEQP NEXTI STARTI)
then (RETURN (IPLUS STARTI TAIL)))
(if (SETQ TEM (FFILEPOS PATTERN STRM NEXTI MAXI SKIP NIL CASEARRAY))
then (SETQ STARTI TEM)
else (SETQ MAXI NEXTI))
(GO NARROWDOWN)))))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(PUTDEF (QUOTE \STRPOSLARRAY)
(QUOTE GLOBALRESOURCES)
(QUOTE (NCREATE (QUOTE CHARTABLE))))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \STRPOSLARRAY)
)
(RPAQQ \STRPOSLARRAY NIL)
(RPAQQ \BFILEPOS.SHORTPATTERNL 16)
(DECLARE: DONTEVAL@LOAD DOCOPY
(MOVD? (QUOTE STRPOS)
(QUOTE BSTRPOS))
(MOVD? (QUOTE STRPOSL)
(QUOTE BSTRPOSL))
)
(PUTPROPS BSEARCH COPYRIGHT ("Xerox Corporation" 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (591 10997 (STRPOS 601 . 4913) (STRPOSL 4915 . 7768) (BFILEPOS 7770 . 10995)))))
STOP