diff --git a/changelog b/changelog index f0ec2f6..eb0cfa4 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090823 tpd src/axiom-website/patches.html 20090823.09.tpd.patch +20090823 tpd src/interp/Makefile move match.boot to match.lisp +20090823 tpd src/interp/match.lisp added, rewritten from match.boot +20090823 tpd src/interp/match.boot removed, rewritten to match.lisp 20090823 tpd src/axiom-website/patches.html 20090823.08.tpd.patch 20090823 tpd src/interp/Makefile move macex.boot to macex.lisp 20090823 tpd src/interp/macex.lisp added, rewritten from macex.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 9d63b98..df54957 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1862,5 +1862,7 @@ intfile.lisp rewrite from boot to lisp
lisplib.lisp rewrite from boot to lisp
20090823.08.tpd.patch macex.lisp rewrite from boot to lisp
+20090823.09.tpd.patch +match.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index a62e467..6efcdc6 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -3480,45 +3480,26 @@ ${MID}/lisplib.lisp: ${IN}/lisplib.lisp.pamphlet @ -\subsection{match.boot} +\subsection{match.lisp} <>= -${OUT}/match.${O}: ${MID}/match.clisp - @ echo 338 making ${OUT}/match.${O} from ${MID}/match.clisp - @ (cd ${MID} ; \ +${OUT}/match.${O}: ${MID}/match.lisp + @ echo 136 making ${OUT}/match.${O} from ${MID}/match.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/match.clisp"' \ + echo '(progn (compile-file "${MID}/match.lisp"' \ ':output-file "${OUT}/match.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/match.clisp"' \ + echo '(progn (compile-file "${MID}/match.lisp"' \ ':output-file "${OUT}/match.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/match.clisp: ${IN}/match.boot.pamphlet - @ echo 339 making ${MID}/match.clisp from ${IN}/match.boot.pamphlet +<>= +${MID}/match.lisp: ${IN}/match.lisp.pamphlet + @ echo 137 making ${MID}/match.lisp from ${IN}/match.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/match.boot.pamphlet >match.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "match.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "match.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm match.boot ) - -@ -<>= -${DOC}/match.boot.dvi: ${IN}/match.boot.pamphlet - @echo 340 making ${DOC}/match.boot.dvi from ${IN}/match.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/match.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} match.boot ; \ - rm -f ${DOC}/match.boot.pamphlet ; \ - rm -f ${DOC}/match.boot.tex ; \ - rm -f ${DOC}/match.boot ) + ${TANGLE} ${IN}/match.lisp.pamphlet >match.lisp ) @ @@ -6256,8 +6237,7 @@ clean: <> <> -<> -<> +<> <> <> diff --git a/src/interp/match.boot.pamphlet b/src/interp/match.boot.pamphlet deleted file mode 100644 index 132b99f..0000000 --- a/src/interp/match.boot.pamphlet +++ /dev/null @@ -1,242 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp match.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -SETANDFILEQ($wildCard,char "*") - -maskMatch?(mask,subject) == - null mask => true - if null STRINGP subject then subject := PNAME subject - or/[match?(pattern,subject) for pattern in mask] - -substring?(part, whole, startpos) == ---This function should be replaced by STRING< - np := SIZE part - nw := SIZE whole - np > nw - startpos => false - and/[CHAR_-EQUAL(ELT(part, ip), ELT(whole, iw)) - for ip in 0..np-1 for iw in startpos.. ] - -anySubstring?(part,whole,startpos) == - np := SIZE part - nw := SIZE whole - or/[((k := i) and and/[CHAR_-EQUAL(ELT(part, ip),ELT(whole, iw)) - for ip in 0..np - 1 for iw in i..]) for i in startpos..nw - np] => k - -charPosition(c,t,startpos) == - n := SIZE t - startpos < 0 or startpos > n => n - k:= startpos - for i in startpos .. n-1 repeat - c = ELT(t,i) => return nil - k := k+1 - k - -rightCharPosition(c,t,startpos) == --startpos often equals MAXINDEX t (rightmost) - k := startpos - for i in startpos..0 by -1 while c ^= ELT(t,i) repeat (k := k - 1) - k - -stringPosition(s,t,startpos) == - n := SIZE t - if startpos < 0 or startpos > n then error "index out of range" - if SIZE s = 0 then return startpos -- bug in STRPOS - r := STRPOS(s,t,startpos,NIL) - if EQ(r,NIL) then n else r - -superMatch?(opattern,subject) == --subject assumed to be DOWNCASEd - $wildCard : local := char '_* - pattern := patternCheck opattern - logicalMatch?(pattern,subject) - -logicalMatch?(pattern,subject) == --subject assumed to be DOWNCASEd - pattern is [op,:argl] => - op = "and" => and/[superMatch?(p,subject) for p in argl] - op = "or" => or/[superMatch?(p,subject) for p in argl] - op = "not" => not superMatch?(first argl,subject) - systemError '"unknown pattern form" - basicMatch?(pattern,subject) - -patternCheck pattern == main where - --checks for escape characters, maybe new $wildCard - main == --- pattern := pmTransFilter pattern --should no longer need this (rdj:10/1/91) - u := pos(char '__,pattern) - null u => pattern - not(and/[equal(pattern,i + 1,$wildCard) for i in u]) => - sayBrightly ['"Invalid use of underscores in pattern: ",pattern] - '"!!!!!!!!!!!!!!" - c := wild(pattern,'(_$ _# _% _& _@)) --- sayBrightlyNT ['"Choosing new wild card"] --- pp c - $oldWild :local := $wildCard - $wildCard := c - pattern := mknew(pattern,first u,rest u,SUBSTRING(pattern,0,first u)) --- sayBrightlyNT ['"Replacing pattern by"] --- pp pattern - pattern - mknew(old,i,r,new) == - new := STRCONC(new,old.(i + 1)) --add underscored character to string - null r => STRCONC(new,subWild(SUBSTRING(old,i + 2,nil),0)) - mknew(old,first r,rest r, - STRCONC(new,subWild(SUBSTRING(old,i + 2,(first r) - i - 1),i + 1))) - subWild(s,i) == - (k := charPosition($oldWild,s,i)) < #s => - STRCONC(SUBSTRING(s,i,k - i),$wildCard,subWild(s,k + 1)) - SUBSTRING(s,i,nil) - pos(c,s) == - i := 0 - n := MAXINDEX s - acc := nil - repeat - k := charPosition(c,s,i) - k > n => return NREVERSE acc - acc := [k,:acc] - i := k + 1 - equal(p,n,c) == - n > MAXINDEX p => false - p.n = c - wild(p,u) == - for id in u repeat - c := char id - not(or/[p.i = c for i in 0..MAXINDEX(p)]) => return c - -match?(pattern,subject) == --returns index of first character that matches - basicMatch?(pattern,DOWNCASE subject) - -stringMatch(pattern,subject,wildcard) == - not CHARP wildcard => - systemError '"Wildcard must be a character" - $wildCard : local := wildcard - subject := DOWNCASE subject - k := basicMatch?(pattern,DOWNCASE subject) => k + 1 - 0 - -basicMatch?(pattern,target) == - n := #pattern - p := charPosition($wildCard,pattern,0) - p = n => (pattern = target) and 0 - if p ^= 0 then - -- pattern does not begin with a wild card - ans := 0 - s := SUBSTRING(pattern,0,p) --[pattern.i for i in 0..p-1] - not substring?(s,target,0) => return false - else if n = 1 then return 0 - i := p -- starting position for searching the target - q := charPosition($wildCard,pattern,p+1) - ltarget := #target - while q ^= n repeat - s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] - i := stringPosition(s,target,i) - if null ans then ans := stringPosition(s,target,p) - -- for patterns beginning with wildcard, ans gives position of first match - if i = ltarget then return (returnFlag := true) - i := i + #s - p := q - q := charPosition($wildCard,pattern,q+1) - returnFlag => false - if p ^= q-1 then - -- pattern does not end with a wildcard - s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] - if not suffix?(s,target) then return false - if null ans then ans := 1 --pattern is a word preceded by a * - ans - -matchSegment?(pattern,subject,k) == - matchAnySegment?(pattern,DOWNCASE subject,k,nil) - -matchAnySegment?(pattern,target,k,nc) == --k = start position; nc=#chars or NIL - n := #pattern - p := charPosition($wildCard,pattern,0) - p = n => - m := stringPosition(pattern,target,k) - m = #target => nil - null nc => true - m <= k + nc - n - if k ^= 0 and nc then - target := SUBSTRING(target,k,nc) - k := 0 - if p ^= 0 then - -- pattern does not begin with a wild card - ans := 0 - s := SUBSTRING(pattern,0,p) --[pattern.i for i in 0..p-1] - not substring?(s,target,k) => return false - else if n = 1 then return true - i := p + k -- starting position for searching the target - q := charPosition($wildCard,pattern,p+1) - ltarget := #target - while q ^= n repeat - s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] - i := stringPosition(s,target,i) - if i = ltarget then return (returnFlag := true) - i := i + #s - p := q - q := charPosition($wildCard,pattern,q+1) - returnFlag => false - if p ^= q-1 then - -- pattern does not end with a '& - s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] - if not suffix?(s,target) then return false - if null ans then ans := 1 --pattern is a word preceded by a * - true - -infix?(s,t,x) == #s + #t >= #x and prefix?(s,x) and suffix?(t,x) - -prefix?(s,t) == substring?(s,t,0) - -suffix?(s,t) == - m := #s; n := #t - if m > n then return false - substring?(s,t,(n-m)) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/match.lisp.pamphlet b/src/interp/match.lisp.pamphlet new file mode 100644 index 0000000..bfc97c6 --- /dev/null +++ b/src/interp/match.lisp.pamphlet @@ -0,0 +1,655 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp match.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= + +(IN-PACKAGE "BOOT" ) + +;SETANDFILEQ($wildCard,char "*") + +(SETANDFILEQ |$wildCard| (|char| (QUOTE *))) + +;maskMatch?(mask,subject) == +; null mask => true +; if null STRINGP subject then subject := PNAME subject +; or/[match?(pattern,subject) for pattern in mask] + +(DEFUN |maskMatch?| (|mask| |subject|) + (PROG () + (RETURN + (SEQ (COND + ((NULL |mask|) 'T) + ('T + (COND + ((NULL (STRINGP |subject|)) + (SPADLET |subject| (PNAME |subject|)))) + (PROG (G166058) + (SPADLET G166058 NIL) + (RETURN + (DO ((G166064 NIL G166058) + (G166065 |mask| (CDR G166065)) + (|pattern| NIL)) + ((OR G166064 (ATOM G166065) + (PROGN + (SETQ |pattern| (CAR G166065)) + NIL)) + G166058) + (SEQ (EXIT (SETQ G166058 + (OR G166058 + (|match?| |pattern| |subject|)))))))))))))) + +;substring?(part, whole, startpos) == +;--This function should be replaced by STRING< +; np := SIZE part +; nw := SIZE whole +; np > nw - startpos => false +; and/[CHAR_-EQUAL(ELT(part, ip), ELT(whole, iw)) +; for ip in 0..np-1 for iw in startpos.. ] + +(DEFUN |substring?| (|part| |whole| |startpos|) + (PROG (|np| |nw|) + (RETURN + (SEQ (PROGN + (SPADLET |np| (SIZE |part|)) + (SPADLET |nw| (SIZE |whole|)) + (COND + ((> |np| (SPADDIFFERENCE |nw| |startpos|)) NIL) + ('T + (PROG (G166078) + (SPADLET G166078 'T) + (RETURN + (DO ((G166085 NIL (NULL G166078)) + (G166086 (SPADDIFFERENCE |np| 1)) + (|ip| 0 (QSADD1 |ip|)) + (|iw| |startpos| (+ |iw| 1))) + ((OR G166085 (QSGREATERP |ip| G166086)) + G166078) + (SEQ (EXIT (SETQ G166078 + (AND G166078 + (CHAR-EQUAL (ELT |part| |ip|) + (ELT |whole| |iw|)))))))))))))))) + +;anySubstring?(part,whole,startpos) == +; np := SIZE part +; nw := SIZE whole +; or/[((k := i) and and/[CHAR_-EQUAL(ELT(part, ip),ELT(whole, iw)) +; for ip in 0..np - 1 for iw in i..]) for i in startpos..nw - np] => k + +(DEFUN |anySubstring?| (|part| |whole| |startpos|) + (PROG (|np| |nw| |k|) + (RETURN + (SEQ (PROGN + (SPADLET |np| (SIZE |part|)) + (SPADLET |nw| (SIZE |whole|)) + (COND + ((PROG (G166098) + (SPADLET G166098 NIL) + (RETURN + (DO ((G166104 NIL G166098) + (G166105 (SPADDIFFERENCE |nw| |np|)) + (|i| |startpos| (+ |i| 1))) + ((OR G166104 (> |i| G166105)) G166098) + (SEQ (EXIT (SETQ G166098 + (OR G166098 + (AND (SPADLET |k| |i|) + (PROG (G166110) + (SPADLET G166110 'T) + (RETURN + (DO + ((G166117 NIL + (NULL G166110)) + (G166118 + (SPADDIFFERENCE |np| 1)) + (|ip| 0 (QSADD1 |ip|)) + (|iw| |i| (+ |iw| 1))) + ((OR G166117 + (QSGREATERP |ip| + G166118)) + G166110) + (SEQ + (EXIT + (SETQ G166110 + (AND G166110 + (CHAR-EQUAL + (ELT |part| |ip|) + (ELT |whole| |iw|) + )))))))))))))))) + |k|))))))) + +;charPosition(c,t,startpos) == +; n := SIZE t +; startpos < 0 or startpos > n => n +; k:= startpos +; for i in startpos .. n-1 repeat +; c = ELT(t,i) => return nil +; k := k+1 +; k + +(DEFUN |charPosition| (|c| |t| |startpos|) + (PROG (|n| |k|) + (RETURN + (SEQ (PROGN + (SPADLET |n| (SIZE |t|)) + (COND + ((OR (MINUSP |startpos|) (> |startpos| |n|)) |n|) + ('T (SPADLET |k| |startpos|) + (DO ((G166136 (SPADDIFFERENCE |n| 1)) + (|i| |startpos| (+ |i| 1))) + ((> |i| G166136) NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |c| (ELT |t| |i|)) + (RETURN NIL)) + ('T (SPADLET |k| (PLUS |k| 1))))))) + |k|))))))) + +;rightCharPosition(c,t,startpos) == --startpos often equals MAXINDEX t (rightmost) +; k := startpos +; for i in startpos..0 by -1 while c ^= ELT(t,i) repeat (k := k - 1) +; k + +(DEFUN |rightCharPosition| (|c| |t| |startpos|) + (PROG (|k|) + (RETURN + (SEQ (PROGN + (SPADLET |k| |startpos|) + (DO ((G166151 (SPADDIFFERENCE 1)) + (|i| |startpos| (+ |i| G166151))) + ((OR (IF (MINUSP G166151) (< |i| 0) (> |i| 0)) + (NULL (NEQUAL |c| (ELT |t| |i|)))) + NIL) + (SEQ (EXIT (SPADLET |k| (SPADDIFFERENCE |k| 1))))) + |k|))))) + +;stringPosition(s,t,startpos) == +; n := SIZE t +; if startpos < 0 or startpos > n then error "index out of range" +; if SIZE s = 0 then return startpos -- bug in STRPOS +; r := STRPOS(s,t,startpos,NIL) +; if EQ(r,NIL) then n else r + +(DEFUN |stringPosition| (|s| |t| |startpos|) + (PROG (|n| |r|) + (RETURN + (PROGN + (SPADLET |n| (SIZE |t|)) + (COND + ((OR (MINUSP |startpos|) (> |startpos| |n|)) + (|error| '|index out of range|))) + (COND ((EQL (SIZE |s|) 0) (RETURN |startpos|))) + (SPADLET |r| (STRPOS |s| |t| |startpos| NIL)) + (COND ((EQ |r| NIL) |n|) ('T |r|)))))) + +;superMatch?(opattern,subject) == --subject assumed to be DOWNCASEd +; $wildCard : local := char '_* +; pattern := patternCheck opattern +; logicalMatch?(pattern,subject) + +(DEFUN |superMatch?| (|opattern| |subject|) + (PROG (|$wildCard| |pattern|) + (DECLARE (SPECIAL |$wildCard|)) + (RETURN + (PROGN + (SPADLET |$wildCard| (|char| '*)) + (SPADLET |pattern| (|patternCheck| |opattern|)) + (|logicalMatch?| |pattern| |subject|))))) + +;logicalMatch?(pattern,subject) == --subject assumed to be DOWNCASEd +; pattern is [op,:argl] => +; op = "and" => and/[superMatch?(p,subject) for p in argl] +; op = "or" => or/[superMatch?(p,subject) for p in argl] +; op = "not" => not superMatch?(first argl,subject) +; systemError '"unknown pattern form" +; basicMatch?(pattern,subject) + +(DEFUN |logicalMatch?| (|pattern| |subject|) + (PROG (|op| |argl|) + (RETURN + (SEQ (COND + ((AND (PAIRP |pattern|) + (PROGN + (SPADLET |op| (QCAR |pattern|)) + (SPADLET |argl| (QCDR |pattern|)) + 'T)) + (COND + ((BOOT-EQUAL |op| '|and|) + (PROG (G166180) + (SPADLET G166180 'T) + (RETURN + (DO ((G166186 NIL (NULL G166180)) + (G166187 |argl| (CDR G166187)) (|p| NIL)) + ((OR G166186 (ATOM G166187) + (PROGN (SETQ |p| (CAR G166187)) NIL)) + G166180) + (SEQ (EXIT (SETQ G166180 + (AND G166180 + (|superMatch?| |p| |subject|))))))))) + ((BOOT-EQUAL |op| '|or|) + (PROG (G166194) + (SPADLET G166194 NIL) + (RETURN + (DO ((G166200 NIL G166194) + (G166201 |argl| (CDR G166201)) (|p| NIL)) + ((OR G166200 (ATOM G166201) + (PROGN (SETQ |p| (CAR G166201)) NIL)) + G166194) + (SEQ (EXIT (SETQ G166194 + (OR G166194 + (|superMatch?| |p| |subject|))))))))) + ((BOOT-EQUAL |op| '|not|) + (NULL (|superMatch?| (CAR |argl|) |subject|))) + ('T + (|systemError| (MAKESTRING "unknown pattern form"))))) + ('T (|basicMatch?| |pattern| |subject|))))))) + +;patternCheck pattern == main where +; --checks for escape characters, maybe new $wildCard +; main == +;-- pattern := pmTransFilter pattern --should no longer need this (rdj:10/1/91) +; u := pos(char '__,pattern) +; null u => pattern +; not(and/[equal(pattern,i + 1,$wildCard) for i in u]) => +; sayBrightly ['"Invalid use of underscores in pattern: ",pattern] +; '"!!!!!!!!!!!!!!" +; c := wild(pattern,'(_$ _# _% _& _@)) +;-- sayBrightlyNT ['"Choosing new wild card"] +;-- pp c +; $oldWild :local := $wildCard +; $wildCard := c +; pattern := mknew(pattern,first u,rest u,SUBSTRING(pattern,0,first u)) +;-- sayBrightlyNT ['"Replacing pattern by"] +;-- pp pattern +; pattern +; mknew(old,i,r,new) == +; new := STRCONC(new,old.(i + 1)) --add underscored character to string +; null r => STRCONC(new,subWild(SUBSTRING(old,i + 2,nil),0)) +; mknew(old,first r,rest r, +; STRCONC(new,subWild(SUBSTRING(old,i + 2,(first r) - i - 1),i + 1))) +; subWild(s,i) == +; (k := charPosition($oldWild,s,i)) < #s => +; STRCONC(SUBSTRING(s,i,k - i),$wildCard,subWild(s,k + 1)) +; SUBSTRING(s,i,nil) +; pos(c,s) == +; i := 0 +; n := MAXINDEX s +; acc := nil +; repeat +; k := charPosition(c,s,i) +; k > n => return NREVERSE acc +; acc := [k,:acc] +; i := k + 1 +; equal(p,n,c) == +; n > MAXINDEX p => false +; p.n = c +; wild(p,u) == +; for id in u repeat +; c := char id +; not(or/[p.i = c for i in 0..MAXINDEX(p)]) => return c + +(DEFUN |patternCheck,wild| (|p| |u|) + (PROG (|c|) + (RETURN + (SEQ (DO ((G166226 |u| (CDR G166226)) (|id| NIL)) + ((OR (ATOM G166226) + (PROGN (SETQ |id| (CAR G166226)) NIL)) + NIL) + (SEQ (SPADLET |c| (|char| |id|)) + (EXIT (IF (NULL (PROG (G166232) + (SPADLET G166232 NIL) + (RETURN + (DO + ((G166238 NIL G166232) + (G166239 (MAXINDEX |p|)) + (|i| 0 (QSADD1 |i|))) + ((OR G166238 + (QSGREATERP |i| G166239)) + G166232) + (SEQ + (EXIT + (SETQ G166232 + (OR G166232 + (BOOT-EQUAL (ELT |p| |i|) + |c|))))))))) + (EXIT (RETURN |c|)))))))))) + +(DEFUN |patternCheck,equal| (|p| |n| |c|) + (SEQ (IF (> |n| (MAXINDEX |p|)) (EXIT NIL)) + (EXIT (BOOT-EQUAL (ELT |p| |n|) |c|)))) + +(DEFUN |patternCheck,pos| (|c| |s|) + (PROG (|n| |k| |acc| |i|) + (RETURN + (SEQ (SPADLET |i| 0) (SPADLET |n| (MAXINDEX |s|)) + (SPADLET |acc| NIL) + (EXIT (DO () (NIL NIL) + (SEQ (SPADLET |k| (|charPosition| |c| |s| |i|)) + (IF (> |k| |n|) + (EXIT (RETURN (NREVERSE |acc|)))) + (SPADLET |acc| (CONS |k| |acc|)) + (EXIT (SPADLET |i| (PLUS |k| 1)))))))))) + +(DEFUN |patternCheck,subWild| (|s| |i|) + (PROG (|k|) + (RETURN + (SEQ (IF (> (|#| |s|) + (SPADLET |k| (|charPosition| |$oldWild| |s| |i|))) + (EXIT (STRCONC (SUBSTRING |s| |i| + (SPADDIFFERENCE |k| |i|)) + |$wildCard| + (|patternCheck,subWild| |s| (PLUS |k| 1))))) + (EXIT (SUBSTRING |s| |i| NIL)))))) + +(DEFUN |patternCheck,mknew| (|old| |i| |r| |new|) + (SEQ (SPADLET |new| (STRCONC |new| (ELT |old| (PLUS |i| 1)))) + (IF (NULL |r|) + (EXIT (STRCONC |new| + (|patternCheck,subWild| + (SUBSTRING |old| (PLUS |i| 2) NIL) 0)))) + (EXIT (|patternCheck,mknew| |old| (CAR |r|) (CDR |r|) + (STRCONC |new| + (|patternCheck,subWild| + (SUBSTRING |old| (PLUS |i| 2) + (SPADDIFFERENCE + (SPADDIFFERENCE (CAR |r|) |i|) 1)) + (PLUS |i| 1))))))) + +(DEFUN |patternCheck| (|pattern|) + (PROG (|$oldWild| |u| |c|) + (DECLARE (SPECIAL |$oldWild|)) + (RETURN + (SEQ (PROGN + (SPADLET |u| (|patternCheck,pos| (|char| '_) |pattern|)) + (COND + ((NULL |u|) |pattern|) + ((NULL (PROG (G166274) + (SPADLET G166274 'T) + (RETURN + (DO ((G166280 NIL (NULL G166274)) + (G166281 |u| (CDR G166281)) + (|i| NIL)) + ((OR G166280 (ATOM G166281) + (PROGN + (SETQ |i| (CAR G166281)) + NIL)) + G166274) + (SEQ (EXIT (SETQ G166274 + (AND G166274 + (|patternCheck,equal| + |pattern| (PLUS |i| 1) + |$wildCard|))))))))) + (|sayBrightly| + (CONS (MAKESTRING + "Invalid use of underscores in pattern: ") + (CONS |pattern| NIL))) + (MAKESTRING "!!!!!!!!!!!!!!")) + ('T + (SPADLET |c| + (|patternCheck,wild| |pattern| '($ |#| % & @))) + (SPADLET |$oldWild| |$wildCard|) + (SPADLET |$wildCard| |c|) + (SPADLET |pattern| + (|patternCheck,mknew| |pattern| (CAR |u|) + (CDR |u|) + (SUBSTRING |pattern| 0 (CAR |u|)))) + |pattern|))))))) + +;match?(pattern,subject) == --returns index of first character that matches +; basicMatch?(pattern,DOWNCASE subject) + +(DEFUN |match?| (|pattern| |subject|) + (|basicMatch?| |pattern| (DOWNCASE |subject|))) + +;stringMatch(pattern,subject,wildcard) == +; not CHARP wildcard => +; systemError '"Wildcard must be a character" +; $wildCard : local := wildcard +; subject := DOWNCASE subject +; k := basicMatch?(pattern,DOWNCASE subject) => k + 1 +; 0 + +(DEFUN |stringMatch| (|pattern| |subject| |wildcard|) + (PROG (|$wildCard| |k|) + (DECLARE (SPECIAL |$wildCard|)) + (RETURN + (COND + ((NULL (CHARP |wildcard|)) + (|systemError| (MAKESTRING "Wildcard must be a character"))) + ('T (SPADLET |$wildCard| |wildcard|) + (SPADLET |subject| (DOWNCASE |subject|)) + (COND + ((SPADLET |k| + (|basicMatch?| |pattern| (DOWNCASE |subject|))) + (PLUS |k| 1)) + ('T 0))))))) + +;basicMatch?(pattern,target) == +; n := #pattern +; p := charPosition($wildCard,pattern,0) +; p = n => (pattern = target) and 0 +; if p ^= 0 then +; -- pattern does not begin with a wild card +; ans := 0 +; s := SUBSTRING(pattern,0,p) --[pattern.i for i in 0..p-1] +; not substring?(s,target,0) => return false +; else if n = 1 then return 0 +; i := p -- starting position for searching the target +; q := charPosition($wildCard,pattern,p+1) +; ltarget := #target +; while q ^= n repeat +; s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] +; i := stringPosition(s,target,i) +; if null ans then ans := stringPosition(s,target,p) +; -- for patterns beginning with wildcard, ans gives position of first match +; if i = ltarget then return (returnFlag := true) +; i := i + #s +; p := q +; q := charPosition($wildCard,pattern,q+1) +; returnFlag => false +; if p ^= q-1 then +; -- pattern does not end with a wildcard +; s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] +; if not suffix?(s,target) then return false +; if null ans then ans := 1 --pattern is a word preceded by a * +; ans + +(DEFUN |basicMatch?| (|pattern| |target|) + (PROG (|n| |ltarget| |returnFlag| |i| |p| |q| |s| |ans|) + (RETURN + (SEQ (PROGN + (SPADLET |n| (|#| |pattern|)) + (SPADLET |p| (|charPosition| |$wildCard| |pattern| 0)) + (COND + ((BOOT-EQUAL |p| |n|) + (AND (BOOT-EQUAL |pattern| |target|) 0)) + ('T + (COND + ((NEQUAL |p| 0) (SPADLET |ans| 0) + (SPADLET |s| (SUBSTRING |pattern| 0 |p|)) + (COND + ((NULL (|substring?| |s| |target| 0)) + (RETURN NIL)))) + ((EQL |n| 1) (RETURN 0)) + ('T NIL)) + (SPADLET |i| |p|) + (SPADLET |q| + (|charPosition| |$wildCard| |pattern| + (PLUS |p| 1))) + (SPADLET |ltarget| (|#| |target|)) + (DO () ((NULL (NEQUAL |q| |n|)) NIL) + (SEQ (EXIT (PROGN + (SPADLET |s| + (SUBSTRING |pattern| + (PLUS |p| 1) + (SPADDIFFERENCE + (SPADDIFFERENCE |q| |p|) 1))) + (SPADLET |i| + (|stringPosition| |s| |target| + |i|)) + (COND + ((NULL |ans|) + (SPADLET |ans| + (|stringPosition| |s| + |target| |p|)))) + (COND + ((BOOT-EQUAL |i| |ltarget|) + (RETURN (SPADLET |returnFlag| 'T)))) + (SPADLET |i| (PLUS |i| (|#| |s|))) + (SPADLET |p| |q|) + (SPADLET |q| + (|charPosition| |$wildCard| + |pattern| (PLUS |q| 1))))))) + (COND + (|returnFlag| NIL) + ('T + (COND + ((NEQUAL |p| (SPADDIFFERENCE |q| 1)) + (SPADLET |s| + (SUBSTRING |pattern| (PLUS |p| 1) + (SPADDIFFERENCE + (SPADDIFFERENCE |q| |p|) 1))) + (COND + ((NULL (|suffix?| |s| |target|)) (RETURN NIL))) + (COND ((NULL |ans|) (SPADLET |ans| 1)) ('T NIL)))) + |ans|))))))))) + +;matchSegment?(pattern,subject,k) == +; matchAnySegment?(pattern,DOWNCASE subject,k,nil) + +(DEFUN |matchSegment?| (|pattern| |subject| |k|) + (|matchAnySegment?| |pattern| (DOWNCASE |subject|) |k| NIL)) + +;matchAnySegment?(pattern,target,k,nc) == --k = start position; nc=#chars or NIL +; n := #pattern +; p := charPosition($wildCard,pattern,0) +; p = n => +; m := stringPosition(pattern,target,k) +; m = #target => nil +; null nc => true +; m <= k + nc - n +; if k ^= 0 and nc then +; target := SUBSTRING(target,k,nc) +; k := 0 +; if p ^= 0 then +; -- pattern does not begin with a wild card +; ans := 0 +; s := SUBSTRING(pattern,0,p) --[pattern.i for i in 0..p-1] +; not substring?(s,target,k) => return false +; else if n = 1 then return true +; i := p + k -- starting position for searching the target +; q := charPosition($wildCard,pattern,p+1) +; ltarget := #target +; while q ^= n repeat +; s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] +; i := stringPosition(s,target,i) +; if i = ltarget then return (returnFlag := true) +; i := i + #s +; p := q +; q := charPosition($wildCard,pattern,q+1) +; returnFlag => false +; if p ^= q-1 then +; -- pattern does not end with a '& +; s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] +; if not suffix?(s,target) then return false +; if null ans then ans := 1 --pattern is a word preceded by a * +; true + +(DEFUN |matchAnySegment?| (|pattern| |target| |k| |nc|) + (PROG (|n| |m| |ltarget| |returnFlag| |i| |p| |q| |s| |ans|) + (RETURN + (SEQ (PROGN + (SPADLET |n| (|#| |pattern|)) + (SPADLET |p| (|charPosition| |$wildCard| |pattern| 0)) + (COND + ((BOOT-EQUAL |p| |n|) + (SPADLET |m| (|stringPosition| |pattern| |target| |k|)) + (COND + ((BOOT-EQUAL |m| (|#| |target|)) NIL) + ((NULL |nc|) 'T) + ('T (<= |m| (SPADDIFFERENCE (PLUS |k| |nc|) |n|))))) + ('T + (COND + ((AND (NEQUAL |k| 0) |nc|) + (SPADLET |target| (SUBSTRING |target| |k| |nc|)) + (SPADLET |k| 0))) + (COND + ((NEQUAL |p| 0) (SPADLET |ans| 0) + (SPADLET |s| (SUBSTRING |pattern| 0 |p|)) + (COND + ((NULL (|substring?| |s| |target| |k|)) + (RETURN NIL)))) + ((EQL |n| 1) (RETURN 'T)) + ('T NIL)) + (SPADLET |i| (PLUS |p| |k|)) + (SPADLET |q| + (|charPosition| |$wildCard| |pattern| + (PLUS |p| 1))) + (SPADLET |ltarget| (|#| |target|)) + (DO () ((NULL (NEQUAL |q| |n|)) NIL) + (SEQ (EXIT (PROGN + (SPADLET |s| + (SUBSTRING |pattern| + (PLUS |p| 1) + (SPADDIFFERENCE + (SPADDIFFERENCE |q| |p|) 1))) + (SPADLET |i| + (|stringPosition| |s| |target| + |i|)) + (COND + ((BOOT-EQUAL |i| |ltarget|) + (RETURN (SPADLET |returnFlag| 'T)))) + (SPADLET |i| (PLUS |i| (|#| |s|))) + (SPADLET |p| |q|) + (SPADLET |q| + (|charPosition| |$wildCard| + |pattern| (PLUS |q| 1))))))) + (COND + (|returnFlag| NIL) + ('T + (COND + ((NEQUAL |p| (SPADDIFFERENCE |q| 1)) + (SPADLET |s| + (SUBSTRING |pattern| (PLUS |p| 1) + (SPADDIFFERENCE + (SPADDIFFERENCE |q| |p|) 1))) + (COND + ((NULL (|suffix?| |s| |target|)) (RETURN NIL))) + (COND ((NULL |ans|) (SPADLET |ans| 1)) ('T NIL)))) + 'T))))))))) + +;infix?(s,t,x) == #s + #t >= #x and prefix?(s,x) and suffix?(t,x) + +(DEFUN |infix?| (|s| |t| |x|) + (AND (>= (PLUS (|#| |s|) (|#| |t|)) (|#| |x|)) (|prefix?| |s| |x|) + (|suffix?| |t| |x|))) + +;prefix?(s,t) == substring?(s,t,0) + +(DEFUN |prefix?| (|s| |t|) (|substring?| |s| |t| 0)) + +;suffix?(s,t) == +; m := #s; n := #t +; if m > n then return false +; substring?(s,t,(n-m)) + +(DEFUN |suffix?| (|s| |t|) + (PROG (|m| |n|) + (RETURN + (PROGN + (SPADLET |m| (|#| |s|)) + (SPADLET |n| (|#| |t|)) + (COND ((> |m| |n|) (RETURN NIL))) + (|substring?| |s| |t| (SPADDIFFERENCE |n| |m|)))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}