(FILECREATED "22-NOV-82 12:25:45" <NEWLISP>MATCH.;1 70242
changes to: (FNS MAKEMATCH PATPARSEAT BINDVAR DOSIDE DOSUBST1 QFOR)
(VARS MATCHBLOCKS MATCHCOMS)
previous date: "27-Jan-82 10:16:46" <LISP>MATCH.;146)
(* Copyright (c) 1982 by Xerox Corporation)
(PRETTYCOMPRINT MATCHCOMS)
(RPAQQ MATCHCOMS ((FNS MAKEMATCH QMATCHSUBPAT QMATCHWM QMATCH$ QMATCH! QMATCH$= QMATCHELT1 QMATCHELT
SIMPLEFN DOSIDE CHECKSETQ DOREPLACE DOREPLACE1)
(FNS PATLEN $? ELT? SIMPLELT? ARB? NULLPAT? NILPAT CANMATCHNIL CANMATCHNILLIST REPLACEIN)
(FNS EASYTORECOMPUTE GENSYML MAKESUBST DOSUBST DOSUBST1 SUBSTVAR BINDVAR SELFQUOTEABLE
FINDIN0 FINDIN1 DOWATCH PATNARGS)
(FNS QNLEFT QNOT QNULL QNOT1 QNOTLESSPLENGTH QNTH QOR QPLUS QREPLACE MKAND QCAR QCDR QEQ
QEQLENGTH QEQUAL QLAST QAPPLY* QLDIFF QFOR QLISTP QNCONC)
(FNS PATERR PATHELP LOOKLIST VALUELOOKUP LOOK)
(FNS MKAND2 CHECKSLISTP EQUALUNCROP)
(FNS PATPARSE PATPARSE1 PATUNPACKINFIX1 PARSEDEFAULT VARCHECK PATUNPACK PATUNPACKINFIX
PATGETFNNAME PATGETEXPR PATPARSEAT MAKE!PAT MAKESUBPAT NEGATEPAT PACKLDIFF)
(VARS PATCHARS PATTERNINFIXES PATTERNINFIXES1 PATTERNREPLACEOPRS PATTERNITEMS
NEVERNILFUNCTIONS PATNONNILFUNCTIONS [PATTERNCHARRAY (MAKEBITTABLE
(NCONC (MAPCAR PATCHARS
(QUOTE CAAR))
(MAPCAR PATTERNITEMS
(QUOTE CAR]
PATGENSYMVARS
(PATVARDEFAULT (QUOTE =))
MAXCDDDDRS
(PATCHECKLENGTH T)
(PATLISTPCHECK (EQ (QUOTE VAX)
(SYSTEMTYPE)))
(PATVARSMIGHTBENIL T))
(VARS PATCHARS PATTERNINFIXES PATTERNINFIXES1 PATTERNREPLACEOPRS PATTERNITEMS
NEVERNILFUNCTIONS PATNONNILFUNCTIONS SIMPLE.PREDICATES
[PATTERNCHARRAY (MAKEBITTABLE (NCONC (MAPCAR PATCHARS (QUOTE CAAR))
(MAPCAR PATTERNITEMS (QUOTE CAR]
PATGENSYMVARS)
(P (OR (BOUNDP (QUOTE MATCHSTATS))
(SETQ MATCHSTATS)))
(VARS PATVARDEFAULT MAXCDDDDRS (PATCHECKLENGTH T)
(PATLISTPCHECK NIL)
(PATVARSMIGHTBENIL T))
(BLOCKS * MATCHBLOCKS)))
(DEFINEQ
(MAKEMATCH
[LAMBDA (MATCHEXPRESSION PATTERN)
(* lmm "22-NOV-82 12:08")
(PROG ((LOCALDECLARATION (GETLOCALDEC EXPR FAULTFN))
#LIST #LISTUSED BOUNDVARS BOUNDVALS CHECKLENGTH LISTPCHECK VARDEFAULT PATVARSNIL
(GENSYMVARLIST PATGENSYMVARS)
CONSTRUCT POSTPONEDRPLACS POSTPONEDSETQS (LASTEFFECTCANBENIL T)
MUSTRETURN WMLST WATCHPOSTPONELST SUBLIST PAT MATCHEFFECTS VAR X INASOME)
(* POSTPONEDSETQS and POSTPONEDRPLACS are used to collect postponed side effects -
LASTEFFECTCANBENIL is a flag which should be set whenever a SETQ is postponed for determining whether the extra T at
the end is necessary -
BOUNDVARS and BOUNDVALS will be list of bindings that need to be done -
MUSTRETURN will be the * expression, if any)
(* CHECKINGLENGTH is the flag whether the length should be checked (used for example in (-- 'A & &) already done the
NLEFT which implicitly checks) -
-
INASOME is a stack, car of which is a that says that we are, at this level, after a -- type pattern, so that if
another -- is encountered, just reset INASOME to the match expression for what comes after the second --;
this is so (-- A -- B --) will generate (MEMB 'B (MEMB 'A X)) instead of (SOME X (F/L (Z) (Z:1='A AND 'B MEMB Z::1))
) -
WMLST is a stack used by *GLITCH for remembering when a ! (SUBPAT --) is encountered to expand it, but remember the
tail after the !SUBPAT and return (by RPLAC'ing into the corresponding entry in WMLIST) the expression for
"WHAT MATCHED" -
SUBLIST is the list where substitutions in the final pattern are collected)
(* WATCHPOSTPONELST is a list of those vars which, when a POSTPONE involving them is encountered, the corresponding
entry in WATCHPOSTPONELST should be rplac'ed ; used to tell whether SOME variables should be local or global)
(SETQ CHECKLENGTH (VALUELOOKUP (QUOTE PATCHECKLENGTH)))
(SETQ LISTPCHECK (VALUELOOKUP (QUOTE PATLISTPCHECK)))
(SETQ VARDEFAULT (VALUELOOKUP (QUOTE PATVARDEFAULT)))
(SETQ PATVARSNIL (VALUELOOKUP (QUOTE PATVARSMIGHTBENIL)))
(* Look up global variables, checking the local declaration)
(SETQ CLISPCHANGE T) (* Tell DWIM that if the match fails not to try to parse it as CLISP)
[COND
(PATTERN (* Old way of calling MAKEMATCH)
(SETQ MATCHEXPRESSION (LIST (QUOTE match)
MATCHEXPRESSION
(QUOTE with)
PATTERN]
(SELECTQ (CAR MATCHEXPRESSION)
[(match MATCH)
(DWIMIFY0? (CDR MATCHEXPRESSION)
MATCHEXPRESSION
(CDR MATCHEXPRESSION)
T T FAULTFN)
[SELECTQ (CADDR MATCHEXPRESSION)
((with WITH))
(COND
((FIXSPELL (CADDR MATCHEXPRESSION)
70
(QUOTE (WITH))
T
(CDDR MATCHEXPRESSION)))
((AND (LISTP (CADDR MATCHEXPRESSION))
(FIXSPELL1 (CADDR MATCHEXPRESSION)
(CONS (QUOTE with)
(CADDR MATCHEXPRESSION))
NIL T))
(/ATTACH (QUOTE with)
(CDDR MATCHEXPRESSION)))
(T (PATERR (QUOTE NOWITH)
(CDDR MATCHEXPRESSION]
(SELECTQ (CAR (CDDDDR MATCHEXPRESSION))
((NIL -> =>))
(PATERR "Expression after pattern not preceded by => or ->"
(CAR (CDDDDR MATCHEXPRESSION]
(HELP "Bad arg to MAKEMATCH"))
(* Make sure expression is in right form)
[SETQ PAT (PROG ((TOPPAT (CADDDR MATCHEXPRESSION)))
(RETURN (PATPARSE TOPPAT]
(* Parse the pattern into internal format)
[SETQ CONSTRUCT (AND (CDDDDR MATCHEXPRESSION)
(PROG ((VARS (APPEND #LIST VARS)))
(DWIMIFY0? (CDR (CDDDDR MATCHEXPRESSION))
MATCHEXPRESSION T NIL NIL FAULTFN)
(RETURN (CDR (CDDDDR MATCHEXPRESSION]
(* Get any expression after => or ->)
[SETQ VAR (COND
((EASYTORECOMPUTE (CADR MATCHEXPRESSION))
(CADR MATCHEXPRESSION))
(T (SUBSTVAR (CADR MATCHEXPRESSION]
(SETQ X (QMATCHSUBPAT VAR PAT))
(SETQ SUBLIST (DREVERSE SUBLIST))
[AND CONSTRUCT (EQ (CAR (CDDDDR MATCHEXPRESSION))
(QUOTE ->))
(SETQ CONSTRUCT (LIST (LIST (QUOTE TOPREPLACE)
VAR
(MKPROGN CONSTRUCT]
[SETQ MATCHEFFECTS (NCONC (DREVERSE POSTPONEDSETQS)
(DREVERSE POSTPONEDRPLACS)
(COND
(CONSTRUCT)
(MUSTRETURN (LIST MUSTRETURN))
((AND LASTEFFECTCANBENIL (NULL POSTPONEDRPLACS))
(LIST T]
[SETQ X (DOSUBST (COND
[MATCHEFFECTS (BQUOTE (COND (, X ,@ MATCHEFFECTS]
(T X]
(RETURN (COND
(BOUNDVARS (BQUOTE ([LAMBDA , BOUNDVARS , X]
,@ BOUNDVALS)))
(T X])
(QMATCHSUBPAT
[LAMBDA (VAR PATELT NOLISTPCHECK) (* lmm "10-AUG-78 15:47")
(PROG ((CHECKINGLENGTH T)
(INASOME (CONS NIL INASOME))) (* Rebind INASOME since this is on a different level;
also CHECKINGLENGTH)
(RETURN (COND
((AND LISTPCHECK (NOT NOLISTPCHECK))
(MKAND (QLISTP VAR)
(QMATCHWM VAR PATELT)))
(T (QMATCHWM VAR PATELT])
(QMATCHWM
[LAMBDA (VAR PAT FN) (* lmm "10-AUG-78 15:47")
(* Creates an expression which will return non-NIL if and only if the value of the VAR expression will match the
parsed pattern PAT, and the expression generated by applying DOSIDE to (the expression giving What-Matched the first
pattern element of PAT) and FN if FN is non-NIL -
is non-nil as well.)
(PROG (TEM1 TEM2)
[COND
((NULL PAT)
(RETURN (OR (NOT CHECKLENGTH)
(NOT CHECKINGLENGTH)
(QNULL VAR]
[COND
((NLISTP (CAR PAT)) (* The only NLISTP patterns are &, $, --, NIL, T,
strings and numbers)
(RETURN (SELECTQ (CAR PAT)
(($ --)
(QMATCH$ VAR PAT FN))
(QMATCHELT1 VAR PAT FN]
(SELECTQ
(CAAR PAT)
((= == ' SUBPAT ~ *ANY*) (* For now, ~'s can only refer to = == ' and subpats ,
i.e. elementary patterns)
(RETURN (QMATCHELT1 VAR PAT FN)))
(! (RETURN (QMATCH! VAR PAT FN)))
($= (RETURN (QMATCH$= VAR PAT FN)))
[@
(COND
[(ELT? (CDDAR PAT))
(COND
[(AND (OR (NEQ (CAR INASOME)
(QUOTE FASTINASOME))
(NEQ (CDDAR PAT)
(QUOTE &)))
(SIMPLEFN (CADAR PAT)))
(* Put simple tests first , unless it is just &@SIMPLEFN, in which case we want to go thru QMATCHELT1 so that the
FASTINASOME will catch the &@FN; for example, in ($ &@LISTP ' A $) find a list and look for A after it, rather than
find a list followed by A)
(RETURN (MKAND (QAPPLY* (CADAR PAT)
(QCAR VAR))
(QMATCHWM VAR (CONS (CDDAR PAT)
(CDR PAT))
FN]
(T (RETURN (QMATCHELT1 VAR PAT FN]
[(CDR PAT) (* SEGMENT@FN followed by something)
(COND
[(AND (NULL FN)
($? (CDDAR PAT))
(ARB? (CADR PAT)
T)) (* $@FN followed by $ or $@)
[SETQ TEM1 (QFOR (QUOTE OLD)
(SETQ TEM1 (GENSYML))
VAR
(MKAND (QAPPLY* (CADAR PAT)
(QLDIFF VAR TEM1))
(QMATCHWM TEM1 (CDR PAT)))
T
(CANMATCHNILLIST (CDR PAT]
(COND
((CAR INASOME)
(FRPLACA INASOME TEM1)
(RETURN T))
(T (RETURN TEM1]
(T
(* segment@FN followed by more pattern -
cannot assume that the INASOME check is legit since ($ (' A $ ' B) @FOO $) check the B MUST repeatedly be checked
for)
(RETURN (PROG ((INASOME (CONS NIL INASOME)))
(RETURN (QMATCHWM
VAR
[LIST (CDDAR PAT)
(CONS (QUOTE @)
(CONS (QAPPLY* (CADAR PAT)
(QLDIFF VAR (QUOTE @)))
(MAKE!PAT (MAKESUBPAT (CDR PAT]
FN]
(T (GO OTHER]
(GO OTHER))
OTHER
(RETURN (QMATCHWM VAR (CONS (CDDAR PAT)
(CDR PAT))
(CONS (CAR PAT)
FN])
(QMATCH$
[LAMBDA (VAR PAT FN) (* lmm "10-AUG-78 15:47")
(PROG (TEM1 TEM2 ZLENFLG (SKIPEDLEN 0)
TAIL)
(RETURN (COND
((NULL (CDR PAT)) (* Pattern ends in $ -
What matched is the whole thing)
(DOSIDE FN VAR))
((CAR INASOME)
(* We are within a tail which began with -- or $; thus, we should not return the match here but instead, smash car
of INASOME to the match expression here and return T -
since there is no point in checking this match expression repeatedly)
(COND
((LISTP (CAR INASOME))
(PATHELP "INASOME mismatch")))
[DOWATCH (FRPLACA INASOME (PROG ((INASOME (CONS NIL INASOME)))
(RETURN (QMATCHWM VAR PAT FN]
(* Want to check for postponed variables -
Now just return T, and let the call that rebound INASOME
pick up the expression)
T)
((ARB? (CADR PAT))
(PATERR "Two $ or -- patterns in a row, ambiguous")
(* Must mean the second is LAST)
)
[[AND (NULL FN)
(PROGN [SETQ TAIL (SOME (CDR PAT)
(FUNCTION (LAMBDA (ELT)
(COND
((EQ ELT (QUOTE &))
(SETQ SKIPEDLEN (QPLUS 1 SKIPEDLEN))
NIL)
((EQ (CAR ELT)
(QUOTE $=))
(SETQ SKIPEDLEN (QPLUS SKIPEDLEN
(CDR ELT)))
NIL)
(T]
(* Returns to the first TAIL of PAT which doesn't begin with a $i or a $$foo -
Sets the variable "LEN" to the total length of things skipped over)
(NOT (ZEROP SKIPEDLEN] (* Special check here, since might have
(... -- $4) or not need any QNLEFT's)
(COND
((OR (NULL TAIL)
(NULLPAT? TAIL))
(QNOTLESSPLENGTH VAR SKIPEDLEN))
((NUMBERP SKIPEDLEN) (* Change ($ $4 ...) to ($4 $ ...))
(QMATCHWM (QNTH VAR (ADD1 SKIPEDLEN))
(CONS (CAR PAT)
TAIL)))
(T (* same here; only the NTH expression is NOT to be
substituted)
(QMATCHWM [QCDR (QCDR (SETQ TEM1 (SUBSTVAR (QNTH VAR SKIPEDLEN]
(CONS (CAR PAT)
TAIL]
[[NILPAT (SETQ TAIL (SOME (CDR PAT)
(FUNCTION (LAMBDA (ELT TEM)
(COND
((NULL (SETQ TEM (PATLEN ELT)))
T)
((ZEROP TEM)
(SETQ ZLENFLG T)
NIL)
(T (SETQ SKIPEDLEN (QPLUS SKIPEDLEN TEM))
NIL]
(* Scans PAT until a pattern element which matches an arbitrary length segment is hit -
Adds the length skipped to the variable SKIPEDLEN; and sets ZLENFLG if finds any of zero length)
(* Skipping over any arbitrary patterns
(though might have setqs in them) check if ends in NIL)
(PROG (CHECKINGLENGTH)
(* If pat ends in (... -- & & &) then just match (NLEFT var 3) against & & &; CHECKINGLENGTH = NIL will keep a
(NULL (CDDDR x)) check away)
[SETQ TEM1 (COND
[[OR (ZEROP SKIPEDLEN)
(AND (EQ (CAR (LISTP VAR))
(QUOTE CDR))
(NOT (ELT? (CADR PAT)))
(REPLACEIN (CADR PAT]
(* Check var::-skipedlen)
(QCDR (SUBSTVAR (QNLEFT (COND
((EQ (CAR (LISTP VAR))
(QUOTE CDR))
(CADR VAR))
(T VAR))
(QPLUS SKIPEDLEN 1)
NIL ZLENFLG]
(T (SUBSTVAR (QNLEFT VAR SKIPEDLEN NIL ZLENFLG]
(RETURN (MKAND (OR (NOT (CANMATCHNILLIST (CDR PAT)))
TEM1)
(MKAND (QMATCHWM TEM1 (CDR PAT))
(OR (NULL FN)
(DOSIDE FN (QLDIFF VAR TEM1]
[[AND (NULL FN)
(EQ TAIL (CDDR PAT))
(EQ SKIPEDLEN 1)
(NULLPAT? TAIL)
(EQ (CAADR PAT)
(QUOTE SUBPAT))
(OR (EQ (CAR PAT)
(QUOTE $))
(EVERY (CDDR (CADR PAT))
(FUNCTION ARB?)))
[COND
[(NLISTP (CADR (CADR PAT)))
(NOT (FMEMB (CADR (CADR PAT))
(QUOTE (& $ --]
(T (FMEMB (CAR (CADR (CADR PAT)))
(QUOTE (= == ']
(FMEMB [CAR (SETQ TEM1 (QMATCHELT (QUOTE DUMMY)
(CADR (CADR PAT]
(QUOTE (EQ EQUAL EQP STREQUAL]
(* PAT: (-- (SUBPAT EQTYPE? ARB?) --))
(PROG [TEM2 (VAR (LIST (SELECTQ (CAR TEM1)
(EQ (LOOK (QUOTE ASSOC)
VAR))
(QUOTE SASSOC))
(CADDR TEM1)
VAR))
(PAT (CONS (QUOTE &)
(CDDR (CADR PAT]
(RETURN (QMATCHSUBPAT (SUBSTVAR VAR)
PAT T]
(T (PROG ({OLD} {FINALLY}EXPR {UNTIL}EXPR {ON}VAR
[INASOME (FRPLACA INASOME (COND
((CAR INASOME)
(PATHELP "INASOME mismatch"))
((EQ (CAR PAT)
(QUOTE $))
(QUOTE FASTINASOME))
(T (QUOTE INASOME]
(WATCHPOSTPONELST (CONS (SETQ TEM1 (GENSYML))
WATCHPOSTPONELST)))
(* WATCHPOSTPONELST is reset so that postponed uses of
it can be detected; needed to set {OLD})
(COND
((AND (EQ (CAR (LISTP VAR))
(QUOTE CDR))
[for X in (CDR PAT) do (COND
((ELT? X)
(RETURN))
((REPLACEIN X)
(RETURN T]
(SETQ {ON}VAR (CADR VAR)))
(SETQ TEM2 (QCDR TEM1)))
(T (SETQ {ON}VAR VAR)
(SETQ TEM2 TEM1)))
(SETQ {UNTIL}EXPR (QMATCHWM TEM2 (CDR PAT)))
[SETQ {FINALLY}EXPR
(COND
[(EQ {UNTIL}EXPR T)
(SELECTQ (CAR INASOME)
((INASOME FASTINASOME NIL)
(PATHELP "bad pattern tail"))
(PROGN (SETQ {UNTIL}EXPR (CAR INASOME))
(OR (NULL FN)
(DOSIDE FN (QLDIFF VAR TEM2]
(T (MKAND (DOSIDE FN (QLDIFF VAR TEM2))
(OR [NEQ (FMEMB (CAR INASOME)
(QUOTE (INASOME FASTINASOME NIL]
(CAR INASOME]
(SETQ {OLD} (EQ (CAR WATCHPOSTPONELST)
(QUOTE FOUND)))
(RETURN (QFOR {OLD} TEM1 {ON}VAR {UNTIL}EXPR {FINALLY}EXPR
(CANMATCHNILLIST (CDR PAT])
(QMATCH!
[LAMBDA (VAR PAT FN) (* lmm "10-AUG-78 15:47")
(PROG (TEM1)
(RETURN
(COND
((NILPAT (CDR PAT))
(MKAND [COND
((EQ (CADAR PAT)
(QUOTE SUBPAT)) (* This isn't really a subpat and so don't rebind
CHECKINGLENGTH etc as in QMATCHSUBPAT)
(QMATCHWM VAR (CDDAR PAT)))
(T (QMATCHELT VAR (CDAR PAT]
(DOSIDE FN VAR)))
((NLISTP (CAR PAT))
(PATERR "Invalid '!'" PAT))
(T
(SELECTQ
(CADAR PAT)
[= (* != X -
Go down VAR and X simultaneously, looking for EQUAL
subelements)
(PROG ((TEMVAR (BINDVAR (GENSYML)))
(TAILVAR (BINDVAR (GENSYML)))
AFTEREXP)
[SETQ AFTEREXP (MKAND (DOSIDE FN (QLDIFF VAR TAILVAR))
(QMATCHWM TAILVAR (CDR PAT]
(RETURN (SUBPAIR (QUOTE (TAILVAR VAR TEMVAR ONVAR FINALLY))
[LIST TAILVAR VAR TEMVAR (CDDAR PAT)
(COND
[(EQ AFTEREXP T)
(QOR (LIST (QNULL TEMVAR)
(QEQUAL TEMVAR TAILVAR]
((NOT (CANMATCHNILLIST (CDR PAT)))
(MKAND (QNULL TEMVAR)
AFTEREXP))
(T (MKAND (QOR (LIST (QNULL TEMVAR)
(QEQUAL TEMVAR TAILVAR)))
AFTEREXP]
(QUOTE (PROG NIL (SETQ TEMVAR ONVAR)
(SETQ TAILVAR VAR)
$$LP
(COND
((NLISTP TEMVAR)
(RETURN FINALLY))
([OR (NLISTP TAILVAR)
(NOT (EQUAL (CAR TEMVAR)
(CAR TAILVAR]
(RETURN)))
(SETQ TAILVAR (CDR TAILVAR))
(SETQ TEMVAR (CDR TEMVAR))
(GO $$LP]
[== (COND
[(NULLPAT? (CDR PAT))
(PROG ((CHECKLENGTH T))
(RETURN (QMATCHWM VAR (LIST (CAR PAT))
FN]
(T (PATERR (QUOTE !AT)
(CDAR PAT]
[' (COND
[[OR (NLISTP (CDDAR PAT))
(CDR (LAST (CDDAR PAT]
(COND
[(NULLPAT? (CDR PAT))
(PROG ((CHECKLENGTH T))
(RETURN (QMATCHWM VAR (LIST (CAR PAT))
FN]
(T (PATERR (QUOTE !AT)
(CDAR PAT]
(T (QMATCHWM VAR (CONS [CONS (QUOTE !)
(CONS (QUOTE SUBPAT)
(MAPCAR (CDDAR PAT)
(FUNCTION (LAMBDA (X)
(CONS (QUOTE ')
X]
(CDR PAT))
FN]
[SUBPAT (* Use the *GLITCH kludge to get the whatmatched of the
rest of the thing)
(COND
[(NULL FN)
(QMATCHWM VAR (APPEND (CDDAR PAT)
(CDR PAT]
(T
(PROG ((WMLST (CONS NIL WMLST)))
(RETURN
(MKAND [QMATCHWM
VAR
(APPEND (CDDAR PAT)
(LIST (CONS (QUOTE *GLITCH)
(CONS WMLST (MAKE!PAT
(MAKESUBPAT (CDR PAT]
(DOSIDE FN (QLDIFF VAR (CAR WMLST]
(PATERR "Invalid use of ! in pattern" (CADAR PAT])
(QMATCH$=
[LAMBDA (VAR PAT FN) (* lmm "10-AUG-78 15:47")
(PROG ((SKIPEDLEN 0)
TEM1 TEM2 TAIL)
(RETURN (COND
((NILPAT (CDR PAT))
(MKAND (OR (NOT CHECKINGLENGTH)
(QEQLENGTH VAR (CDAR PAT)))
(DOSIDE FN VAR)))
[(AND (NULL FN)
(COND
([NULLPAT? (SETQ TAIL (SOME (CDR PAT)
(FUNCTION (LAMBDA (ELT)
(COND
((EQ ELT (QUOTE &))
(SETQ SKIPEDLEN (QPLUS 1 SKIPEDLEN))
NIL)
((EQ (CAR ELT)
(QUOTE $=))
(SETQ SKIPEDLEN (QPLUS SKIPEDLEN
(CDR ELT)))
NIL)
(T]
[SETQ TEM2 (OR (NOT CHECKINGLENGTH)
(QNOTLESSPLENGTH VAR (QPLUS (CDAR PAT)
SKIPEDLEN]
(COND
((CAR INASOME)
(DOWATCH (CAR (FRPLACA INASOME TEM2)))
T)
(T TEM2)))
((NULL TAIL)
(QEQLENGTH VAR (QPLUS (CDAR PAT)
SKIPEDLEN]
[(ZEROP (CDAR PAT))
(MKAND (DOSIDE FN (QLDIFF VAR VAR))
(QMATCHWM VAR (CDR PAT]
(T [SETQ TEM1 (COND
((AND (NUMBERP (CDAR PAT))
(ILESSP (CDAR PAT)
MAXCDDDDRS))
(QNTH VAR (CDAR PAT)))
(T (SUBSTVAR (QNTH VAR (CDAR PAT]
(MKAND (OR (NOT CHECKINGLENGTH)
(NOT (CANMATCHNILLIST (CDR PAT)))
TEM1)
(MKAND (DOSIDE FN (QLDIFF VAR (QCDR TEM1)))
(QMATCHWM (QCDR TEM1)
(CDR PAT])
(QMATCHELT1
[LAMBDA (VAR PAT FN) (* lmm "10-AUG-78 15:47")
(MKAND [OR (NOT CHECKINGLENGTH)
(COND
((CDR PAT)
(COND
((AND (CANMATCHNIL (CAR PAT))
(CANMATCHNILLIST (CDR PAT)))
VAR)
(T T)))
((CANMATCHNIL (CAR PAT))
(QEQLENGTH VAR 1))
(T (QNULL (QCDR VAR]
(MKAND (QMATCHELT (QCAR VAR)
(CAR PAT))
(MKAND (DOSIDE FN (QCAR VAR))
(OR (NULL (CDR PAT))
(COND
([AND (EQ (CAR INASOME)
(QUOTE FASTINASOME))
(COND
[(LISTP (CAR PAT))
(FMEMB (CAAR PAT)
(QUOTE (= == ' *ANY* @ SUBPAT]
(T (NOT (FMEMB (CAR PAT)
(QUOTE ($1 &]
[FRPLACA INASOME (PROG ((INASOME (CONS NIL INASOME)))
(RETURN (QMATCHWM (QCDR VAR)
(CDR PAT]
T)
(T (QMATCHWM (QCDR VAR)
(CDR PAT])
(QMATCHELT
[LAMBDA (VAR PATELT) (* lmm "10-AUG-78 15:47")
(* This function matches VAR against PATELT when PATELT
is a pattern element)
(COND
((NLISTP PATELT)
(SELECTQ PATELT
(($ -- &)
T)
(QEQUAL VAR PATELT)))
(T (SELECTQ (CAR PATELT)
(== (QEQ VAR (CDR PATELT)))
[@ (COND
[(SIMPLEFN (CADR PATELT))
(MKAND (QAPPLY* (CADR PATELT)
VAR)
(QMATCHELT VAR (CDDR PATELT]
(T (MKAND (QMATCHELT VAR (CDDR PATELT))
(QAPPLY* (CADR PATELT)
VAR]
[*ANY* (QOR (MAPCAR (CDR PATELT)
(FUNCTION (LAMBDA (X)
(QMATCHELT VAR X]
[~ (QNOT (QMATCHELT VAR (CDR PATELT]
[' (QEQUAL VAR (KWOTE (CDR PATELT]
(= (QEQUAL VAR (CDR PATELT)))
(SUBPAT (QMATCHSUBPAT VAR (CDR PATELT)))
($= (COND
[CHECKINGLENGTH (COND
(CHECKLENGTH (QEQLENGTH VAR (CDR PATELT)))
(T (QNOTLESSPLENGTH VAR (CDR PATELT]
(T T)))
(PATHELP "MATCHELT invalid pattern"])
(SIMPLEFN
[LAMBDA (FN) (* lmm: "17-NOV-76 19:20:38")
(* Cheap test if FN is "simple"; here, just means LISTP NLISTP, EXPRP, LITATOM, etc; want to know if it is cheaper
to match pattern first, or to check FN first)
(FMEMB FN SIMPLE.PREDICATES])
(DOSIDE
[LAMBDA (WHATTODO X) (* lmm "22-NOV-82 12:24")
(OR (NULL WHATTODO)
(MKAND (SELECTQ (CAAR WHATTODO)
[<- (OR (CHECKSETQ X WHATTODO)
(MKPROGN (CONS (LIST (QUOTE SETQ)
(CADAR WHATTODO)
X)
(AND (CANMATCHNIL (CDDAR WHATTODO))
(LIST T]
(← (OR (CHECKSETQ X WHATTODO)
(PROGN (DOWATCH (CADAR WHATTODO))
(DOWATCH X)
(PUSH POSTPONEDSETQS (LIST (QUOTE SETQ)
(CADAR WHATTODO)
X))
(SETQ LASTEFFECTCANBENIL (CANMATCHNIL (CDDAR WHATTODO)))
T)))
(-> (QREPLACE X (CADAR WHATTODO)))
(% (DOWATCH (CADAR WHATTODO))
(DOWATCH X)
(SETQ POSTPONEDRPLACS (CONS (QREPLACE X (CADAR WHATTODO))
POSTPONEDRPLACS))
T)
(@ (QAPPLY* (CADAR WHATTODO)
X))
(*GLITCH (FRPLACA (CADAR WHATTODO)
X)
(DOWATCH X)
T)
(PATHELP "MATCH FUNARG MISMATCH" WHATTODO))
(DOSIDE (CDR WHATTODO)
X])
(CHECKSETQ
[LAMBDA (X ARGS)
(COND
((FMEMB (CADAR ARGS)
#LIST)
[COND
((FMEMB (CADAR ARGS)
#LISTUSED)
(MAP INASOME (FUNCTION (LAMBDA (SL)
(AND (OR (EQ (CAR SL)
(QUOTE INASOME))
(EQ (CAR SL)
(QUOTE FASTINASOME)))
(RPLACA SL NIL]
(MAKESUBST (CADAR ARGS)
X
(QUOTE WATCH))
T)
((EQ (CADAR ARGS)
(QUOTE *))
(DOWATCH X)
(SETQ MUSTRETURN X)
T])
(DOREPLACE
[LAMBDA (EXPRESSION SUBSTDONE)
(PROG NIL
LP [SETQ EXPRESSION (OR (DOREPLACE1 (CADR EXPRESSION)
(CADDR EXPRESSION)
(EQ (CAR EXPRESSION)
(QUOTE TOPREPLACE))
SUBSTDONE)
(PROGN [AND (NOT SUBSTDONE)
(SETQ SUBSTDONE T)
(SETQ EXPRESSION (CONS (CAR EXPRESSION)
(OR (DOSUBST1 (CDR EXPRESSION))
(CDR EXPRESSION]
(GO LP]
(RETURN (COND
(SUBSTDONE EXPRESSION)
(T (OR (DOSUBST1 EXPRESSION)
EXPRESSION])
(DOREPLACE1
[LAMBDA (EXPR1 EXPR2 TOPFLG SUBSTDONE) (* lmm "10-AUG-78 18:32")
(OR (EQUAL EXPR1 EXPR2)
(AND TOPFLG (SELECTQ (CAR EXPR2)
[(CONS LIST)
(MKAND2 (DOREPLACE1 (QCAR EXPR1)
(CADR EXPR2)
T T)
(OR (AND (EQ (CAR EXPR2)
(QUOTE LIST))
(NULL (CDDR EXPR2)))
(DOREPLACE1 (QCDR EXPR1)
(COND
((EQ (CAR EXPR2)
(QUOTE LIST))
(CONS (QUOTE LIST)
(CDDR EXPR2)))
(T (CADDR EXPR2)))
T T]
NIL))
(SELECTQ (CAR EXPR1)
(CAR (LIST (LOOK (QUOTE RPLACA))
(CADR EXPR1)
EXPR2))
(CDR (LIST (LOOK (QUOTE RPLACD))
(CADR EXPR1)
EXPR2))
(LDIFF (DOREPLACE1 (CADR EXPR1)
(QNCONC EXPR2 (CADDR EXPR1))
TOPFLG SUBSTDONE))
(AND SUBSTDONE (LOOKLIST (QUOTE RPLNODE2)
EXPR1 EXPR2])
)
(DEFINEQ
(PATLEN
[LAMBDA (PATELT !ED)
(PROG NIL
LP (RETURN (COND
[(NLISTP PATELT)
(SELECTQ PATELT
(($ --)
NIL)
(& (AND (NOT !ED)
1))
(COND
(!ED 0)
(T 1]
(T (SELECTQ (CAR PATELT)
(SUBPAT (COND
[!ED (for PE1 in (CDR PATELT) bind (PLEN ← 0)
finally (RETURN PLEN)
do (SETQ PLEN (QPLUS PLEN (OR (PATLEN PE1)
(RETURN NIL]
(T 1)))
($= (CDR PATELT))
((← -> <- % @ *GLITCH)
(SETQ PATELT (CDDR PATELT))
(GO LP))
(! (SETQ PATELT (CDR PATELT))
(SETQ !ED T)
(GO LP))
(*ANY* (COND
(!ED NIL)
(T 1)))
(' (COND
(!ED (LENGTH (CDR PATELT)))
(T 1)))
((= == ~) (* Currently, ~ can only refer to subpatterns, =, ==,
and ')
(AND (NOT !ED)
1))
(($> $<)
NIL)
(PATHELP "PATLEN invalid pattern" PATELT])
($?
[LAMBDA (PATELT)
(OR (EQ PATELT (QUOTE --))
(EQ PATELT (QUOTE $])
(ELT?
[LAMBDA (PATELT)
(COND
[(NLISTP PATELT)
(OR (NUMBERP PATELT)
(STRINGP PATELT)
(FMEMB PATELT (QUOTE (& NIL T]
(T (SELECTQ (CAR PATELT)
((= == ' SUBPAT ~ *ANY*) (* Currently, ~ can only refer to =, ==, ' , and
subpatterns)
T)
((← -> <- % @ *GLITCH)
(ELT? (CDDR PATELT)))
NIL])
(SIMPLELT?
[LAMBDA (PATELT)
(OR (NLISTP PATELT)
(SELECTQ (CAR PATELT)
(@ (SIMPLELT? (CDDR PATELT)))
((← -> <- %)
NIL)
T])
(ARB?
[LAMBDA (PATELT @OKFLG)
(COND
((NLISTP PATELT)
($? PATELT))
(T (SELECTQ (CAR PATELT)
(! NIL)
(@ @OKFLG)
((<- % ← -> *GLITCH)
(ARB? (CDDR PATELT)@OKFLG))
NIL])
(NULLPAT?
[LAMBDA (PAT)
(COND
((NULL PAT)
(NOT CHECKLENGTH))
(T (EVERY PAT (FUNCTION $?])
(NILPAT
[LAMBDA (PATLIST)
(AND CHECKLENGTH (NULL PATLIST])
(CANMATCHNIL
[LAMBDA (PATELT) (* Returns T if PATELT matches NIL, NIL if it doesn't,
and something ELSE (maybe) if it might
(e.g., =FOO))
(COND
((NLISTP PATELT)
(AND (FMEMB PATELT (QUOTE (& NIL $ --)))
T))
((NLISTP (CAR PATELT))
(SELECTQ (CAR PATELT)
[@ (AND (CANMATCHNIL (CDDR PATELT))
(NOT (FMEMB (CADR PATELT)
PATNONNILFUNCTIONS))
(QUOTE (MAYBE, MAYBE NOT]
[SUBPAT (AND (NOT LISTPCHECK)
(CANMATCHNILLIST (CDR PATELT]
($< T)
($= (OR (NOT (NUMBERP (CDR PATELT)))
(ILESSP (CDR PATELT)
1)))
($> NIL)
((← -> % <- *GLITCH)
(CANMATCHNIL (CDDR PATELT)))
[! (COND
((EQ (CADR PATELT)
(QUOTE SUBPAT))
(CANMATCHNILLIST (CDDR PATELT)))
(T (CANMATCHNIL (CDR PATELT]
(' (NULL (CDR PATELT)))
[(= ==)
(NOT (COND
[(LITATOM (CDR PATELT))
(OR (EQ (CDR PATELT)
T)
(AND (CDR PATELT)
(NOT PATVARSNIL]
(T (OR (NLISTP (CDR PATELT))
(FMEMB (GETP (CAR (CDR PATELT))
(QUOTE CLISPCLASS))
(QUOTE (+ * ↑ RPLACA RPLACD / - +-)))
(FMEMB (CAR (CDR PATELT))
NEVERNILFUNCTIONS]
(*ANY* (SOME (CDR PATELT)
(FUNCTION CANMATCHNIL)))
(~ (CDR PATELT))
(PATHELP "CANMATCHNIL invalid pattern" PATELT)))
(T (PATHELP "CANMATCHNIL invalid pattern"])
(CANMATCHNILLIST
[LAMBDA (PATLIST)
(EVERY PATLIST (FUNCTION (LAMBDA (PE)
(AND (OR (NOT CHECKINGLENGTH)
(NOT (ELT? PE)))
(CANMATCHNIL PE])
(REPLACEIN
[LAMBDA (PATELT)
(AND (LISTP PATELT)
(SELECTQ (CAR PATELT)
((-> % *GLITCH) (* the *GLITCH might or might not be a replace, but
can't take any chances)
T)
((@ ← <-)
(REPLACEIN (CDDR PATELT)))
(! (REPLACEIN (CDR PATELT)))
(SUBPAT (SOME (CDR PATELT)
(FUNCTION REPLACEIN)))
(($= = == ' $< $> ~ *ANY*) (* All of these cannot be pointing at a REPLACE)
NIL)
(PATHELP "Invalid pattern REPLACEIN" PATELT])
)
(DEFINEQ
(EASYTORECOMPUTE
[LAMBDA (EXPRESSION)
(* If the EXPRESSION is some cadddaars of a variable, return that variable (something needs to check for VARS bound
IN somes and internal forms for WHEN it can't use it for the *'s value))
(OR (AND (NLISTP EXPRESSION)
EXPRESSION)
(AND [OR (GETP (CAR EXPRESSION)
(QUOTE CROPS))
(FMEMB (CAR EXPRESSION)
(QUOTE (CAR CDR]
(EASYTORECOMPUTE (CADR EXPRESSION])
(GENSYML
[LAMBDA NIL
(bind TEM until (NOT (FMEMB (SETQ TEM (OR (CAR (SETQ GENSYMVARLIST (CDR GENSYMVARLIST)))
(GENSYM)))
VARS))
finally (RETURN TEM])
(MAKESUBST
[LAMBDA (VAR VAL FLG)
[COND
((NULL VAR)
(SETQ VAR (GENSYML]
(COND
((EQ FLG (QUOTE WATCH))
(DOWATCH VAR)
(DOWATCH VAL)))
(SETQ SUBLIST (CONS (CONS VAR (CONS VAL (SELECTQ FLG
(T T)
(WATCH (NEQ (EASYTORECOMPUTE VAL)))
NIL)))
SUBLIST))
VAR])
(DOSUBST
[LAMBDA (EXPRESSION)
(* This function does the post substitution in the EXPRESSION; it uses SUBLIST to substitute;
an entry in SUBLIST is (VAR NEWVALUE . FOUND) where FOUND is initially NIL; when the VAR is found for the first
time, the FOUND field is smashed with a pointer to that place of substitution; then if it is found again, the old
place is smashed with a (SETQ $$I VALUE) and then the newvalue is made $$I, and "FOUND" is changed to T -
thus, if an expression occurs once, it is substituted directly; more than once and (SETQ $$I -) is put in the first
place and $$I in the rest)
(OR (COND
[(NLISTP EXPRESSION)
(CAR (DOSUBST1 (LIST EXPRESSION]
(T (DOSUBST1 EXPRESSION)))
EXPRESSION])
(DOSUBST1
[LAMBDA (EXPRESSION) (* lmm "22-NOV-82 12:24")
(PROG (TEM1 TEM2)
(RETURN
(COND
((NLISTP EXPRESSION)
NIL)
[[AND (NLISTP (CAR EXPRESSION))
(SETQ TEM1 (find X in SUBLIST suchthat (COND
[(NLISTP X)
(COND
((EQ X (CAR EXPRESSION))
(RETURN]
(T (EQ (CAR X)
(CAR EXPRESSION]
(* (CAR EXPRESSION) needs to be substituted for)
(SETQ EXPRESSION (CONS (CAR EXPRESSION)
(CDR EXPRESSION)))
[COND
((LISTP (CDDR TEM1))
(* We have already substituted for it)
(SETQ TEM2 (BINDVAR (GENSYML)))
(FRPLACA (CDDR TEM1)
(LIST (QUOTE SETQ)
TEM2
(CADDR TEM1)))
(FRPLACA (CDR TEM1)
TEM2)
(FRPLACD (CDR TEM1)
T) (* Mark it that it's been found twice)
)
((NULL (CDDR TEM1))
(* Haven't seen it before -
if CADR TEM1 is NLISTP this means that CAR TEM1 -> CADR TEM1 directly -
none of this SETQ jazz; so we put T there; otherwise, we save EXPRESSION so that if TEM1:1 occurs again we can go
back and wrap setq around the computation of TEM1:2)
(FRPLACD (CDR TEM1)
(COND
((NLISTP (CADR TEM1))
T)
(T EXPRESSION]
(FRPLACA EXPRESSION (CADR TEM1))
(* Might need to substitutions within substituted EXPRESSION)
(COND
((NLISTP (CAR EXPRESSION))
(OR (DOSUBST1 EXPRESSION)
EXPRESSION))
(T (FRPLACA EXPRESSION (OR (DOSUBST1 (CAR EXPRESSION))
(CAR EXPRESSION)))
(FRPLACD EXPRESSION (OR (DOSUBST1 (CDR EXPRESSION))
(CDR EXPRESSION]
(T (SELECTQ (CAR EXPRESSION)
[LAMBDA
(* Don't want to substitute for lambda variables within the lambda; this is so that the same variable can be used
for a some tail within the some and outside of it)
(PROG ((SUBLIST (APPEND (CADR EXPRESSION)
SUBLIST))
TEM)
(RETURN (COND
((SETQ TEM (DOSUBST1 (CDDR EXPRESSION)))
(CONS (CAR EXPRESSION)
(CONS (CADR EXPRESSION)
TEM]
[PROG (PROG (V TEM FLG)
[SETQ V (MAPCAR (CADR EXPRESSION)
(FUNCTION (LAMBDA (X)
(COND
([AND (LISTP X)
(SETQ TEM (DOSUBST1 (CDR X]
(SETQ FLG T)
(CONS (CAR X)
TEM))
(T X]
(RETURN (PROG ((SUBLIST (NCONC [MAPCAR (CADR EXPRESSION)
(FUNCTION (LAMBDA (X)
(COND
((LISTP X)
(CAR X))
(T X]
SUBLIST)))
(RETURN (COND
((OR (SETQ TEM (DOSUBST1 (CDDR
EXPRESSION)))
FLG)
(CONS (CAR EXPRESSION)
(CONS V (OR TEM (CDDR
EXPRESSION]
(QUOTE NIL)
((TOPREPLACE REPLACE)
(DOREPLACE EXPRESSION))
(COND
[(SELECTQ (CAR EXPRESSION)
((CAR CDR)
(SELECTQ (CAADR EXPRESSION)
((CAR CDR)
T)
NIL))
NIL)
(SETQ TEM1 (OR (DOSUBST1 (CADR EXPRESSION))
(CADR EXPRESSION)))
(COND
((EQ (CAR EXPRESSION)
(QUOTE CDR))
(QCDR TEM1))
(T (QCAR TEM1]
(T (PROG (A D)
(SETQ A (DOSUBST1 (CAR EXPRESSION)))
(SETQ D (DOSUBST1 (CDR EXPRESSION)))
(COND
((EQ (CAR EXPRESSION)
(QUOTE DUMMY))
(AND D (FRPLACD EXPRESSION D))
(RETURN)))
(RETURN (AND (OR A D)
(CONS (OR A (CAR EXPRESSION))
(OR D (CDR EXPRESSION])
(SUBSTVAR
[LAMBDA (X) (* lmm: "27-JUN-77 12:23")
(MAKESUBST (GENSYML)
X])
(BINDVAR
[LAMBDA (VAR VAL) (* lmm "22-NOV-82 12:07")
(PUSH BOUNDVARS VAR)
(PUSH BOUNDVALS VAL)
VAR])
(SELFQUOTEABLE
[LAMBDA (EXPRESSION)
(OR (NUMBERP EXPRESSION)
(STRINGP EXPRESSION)
(NULL EXPRESSION)
(EQ EXPRESSION T])
(FINDIN0
[LAMBDA (VAR X) (* lmm: "27-JUN-77 12:23")
(OR (FINDIN1 VAR X)
(SOME SUBLIST (FUNCTION (LAMBDA (X)
(AND (FINDIN1 (CAR X)
X)
(FINDIN1 VAR (CDR X])
(FINDIN1
[LAMBDA (AT LST) (* CHEAP EDITFINDP)
(OR (EQ AT LST)
(AND (LISTP LST)
(OR (FINDIN1 AT (CAR LST))
(FINDIN1 AT (CDR LST])
(DOWATCH
[LAMBDA (X) (* lmm: "27-JUN-77 12:23")
(AND WATCHPOSTPONELST (MAP WATCHPOSTPONELST (FUNCTION (LAMBDA (X)
(AND (NEQ (CAR X)
(QUOTE FOUND))
(FINDIN0 (CAR X)
X)
(FRPLACA X (QUOTE FOUND])
(PATNARGS
[LAMBDA (X)
(OR (GETP X (QUOTE NARGS))
(NARGS X])
)
(DEFINEQ
(QNLEFT
[LAMBDA (EXPRESSION N TAIL NOTFASTFLG) (* lmm: 25-FEB-76 2 19)
(COND
(TAIL (LIST (LOOK (QUOTE NLEFT))
EXPRESSION N TAIL))
((ZEROP N) (* NO LOOKUP DONE SINCE FLAST DOESN'T MAKE SENSE HERE)
(LIST (QUOTE CDR)
(LIST (QUOTE LAST)
EXPRESSION)))
[(EQ N 1)
(COND
(NOTFASTFLG (LIST (QUOTE LAST)
EXPRESSION))
(T (QLAST EXPRESSION]
(T (LIST (LOOK (QUOTE NLEFT))
EXPRESSION N])
(QNOT
[LAMBDA (X)
(QNOT1 X (QUOTE NOT])
(QNULL
[LAMBDA (X)
(QNOT1 X (QUOTE NULL])
(QNOT1
[LAMBDA (X FNNAME)
(COND
((NLISTP X)
(SELECTQ X
((NIL T)
(PATERR "NULL check of T or NIL; possibly a bad pattern"))
(LIST FNNAME X)))
(T (SELECTQ (CAR X)
((NOT NULL)
(CADR X))
(EQ (FRPLACA X (QUOTE NEQ)))
(NEQ (FRPLACA X (QUOTE EQ)))
(LISTP (FRPLACA X (QUOTE NLISTP)))
(NLISTP (FRPLACA X (QUOTE LISTP)))
(LIST FNNAME X])
(QNOTLESSPLENGTH
[LAMBDA (X N)
(COND
((ZEROP N)
T)
(T (QNTH X N])
(QNTH
[LAMBDA (VAR LEN)
(COND
((OR (NOT (SMALLP LEN))
(ILESSP LEN 1))
(LIST (COND
(CHECKINGLENGTH (LOOK (QUOTE NTH)))
(T (QUOTE FNTH)))
VAR LEN))
((IGREATERP LEN MAXCDDDDRS)
(while (EQ (CAR (LISTP VAR))
(QUOTE CDR))
do (SETQ LEN (IPLUS LEN 1))
(SETQ VAR (CADR VAR)))
(LIST (QUOTE NTH)
VAR LEN))
(T (while (IGREATERP (SETQ LEN (SUB1 LEN))
0)
do (SETQ VAR (LIST (QUOTE CDR)
VAR)))
VAR])
(QOR
[LAMBDA (LISTOFEXPRESSIONS)
(COND
((CDR LISTOFEXPRESSIONS)
(CONS (QUOTE OR)
LISTOFEXPRESSIONS))
(T (CAR LISTOFEXPRESSIONS])
(QPLUS
[LAMBDA (EXPR1 EXPR2)
(COND
((AND (NUMBERP EXPR1)
(NUMBERP EXPR2))
(IPLUS EXPR1 EXPR2))
(T (LIST (QUOTE IPLUS)
EXPR1 EXPR2])
(QREPLACE
[LAMBDA (VAR EXPRESSION)
(LIST (QUOTE REPLACE)
VAR EXPRESSION])
(MKAND
[LAMBDA (X Y) (* lmm "10-AUG-78 23:00")
(OR (MKAND2 X Y)
(LIST (QUOTE AND)
X Y])
(QCAR
[LAMBDA (X)
(LIST (QUOTE CAR)
X])
(QCDR
[LAMBDA (X)
(LIST (QUOTE CDR)
X])
(QEQ
[LAMBDA (VAR EXPRESSION)
(COND
((NULL EXPRESSION)
(QNULL VAR))
((ZEROP EXPRESSION)
(LIST (QUOTE ZEROP)
VAR))
(T (LIST (QUOTE EQ)
VAR EXPRESSION])
(QEQLENGTH
[LAMBDA (VAR LEN) (* lmm: 25-FEB-76 2 10)
(COND
((ZEROP LEN)
(QNULL VAR))
((EQ (CAR (LISTP VAR))
(QUOTE CDR))
(QEQLENGTH (CADR VAR)
(QPLUS 1 LEN)))
(T (LIST (LOOK (QUOTE EQLENGTH))
VAR LEN])
(QEQUAL
[LAMBDA (VAR EXPRESSION)
[COND
([AND (LISTP EXPRESSION)
(EQ (CAR EXPRESSION)
(QUOTE QUOTE))
(SELFQUOTEABLE (CAR (LISTP (CDR EXPRESSION]
(SETQ EXPRESSION (CADR EXPRESSION]
(COND
((NULL EXPRESSION)
(QNULL VAR))
((EQ EXPRESSION T)
(QEQ VAR EXPRESSION))
(T (LIST (COND
([OR (SMALLP EXPRESSION)
(AND (LISTP EXPRESSION)
(EQ (CAR EXPRESSION)
(QUOTE QUOTE))
(LITATOM (CAR (LISTP (CDR EXPRESSION]
(QUOTE EQ))
((NUMBERP EXPRESSION)
(QUOTE EQP))
((STRINGP EXPRESSION)
(QUOTE STREQUAL))
(T (QUOTE EQUAL)))
VAR EXPRESSION])
(QLAST
[LAMBDA (X)
(LIST (LOOK (QUOTE LAST)
X)
X])
(QAPPLY*
[LAMBDA (FNNAME VAR)
(COND
((OR (NLISTP FNNAME)
(EQ (CAR FNNAME)
(QUOTE LAMBDA)))
(LIST FNNAME VAR))
(T (SUBST VAR (QUOTE @)
FNNAME])
(QLDIFF
[LAMBDA (X Y) (* lmm: 25-FEB-76 2 18)
(LIST (LOOK (QUOTE LDIFF))
X Y])
(QFOR
[LAMBDA ({OLD} I.V. {ON}VAR {UNTIL}EXPR {FINALLY}EXPR NOSOMEFLG)
(* lmm "22-NOV-82 12:16")
(PROG (TEM1)
(AND (EQ {UNTIL}EXPR T)
(PATHELP " a SOME with null terminator" (LIST {OLD} I.V. {ON}VAR {FINALLY}EXPR)))
(AND (EQ {UNTIL}EXPR I.V.)
(PATERR (QUOTE BACKTRACK)))
(AND NOSOMEFLG (GO DOPROG))
[COND
((AND (EQ (CAR (LISTP {UNTIL}EXPR))
(QUOTE AND))
(EQ (CADR {UNTIL}EXPR)
I.V.))
(SETQ {UNTIL}EXPR (COND
((CDDDR {UNTIL}EXPR)
(CONS (QUOTE AND)
(CDDR {UNTIL}EXPR)))
(T (CADDR {UNTIL}EXPR]
[SETQ TEM1
(OR (SELECTQ (CAR (LISTP {UNTIL}EXPR))
(EQ (AND (EQUAL (CADR {UNTIL}EXPR)
(QCAR I.V.))
(LOOKLIST (QUOTE MEMB)
(CADDR {UNTIL}EXPR)
{ON}VAR)))
(EQUAL (AND (EQUAL (CADR {UNTIL}EXPR)
(QCAR I.V.))
(LIST (QUOTE MEMBER)
(CADDR {UNTIL}EXPR)
{ON}VAR)))
NIL)
(LIST (QUOTE SOME)
{ON}VAR
(PROG ((ARGS (LIST (GENSYML)
I.V.)))
(RETURN (LIST (QUOTE FUNCTION)
(COND
([AND (EQ (CADR {UNTIL}EXPR)
(CAR ARGS))
(OR (AND (EQLENGTH {UNTIL}EXPR 2)
(EQ (PATNARGS (CAR {UNTIL}EXPR))
1))
(AND (EQ (PATNARGS (CAR {UNTIL}EXPR))
1)
(EQLENGTH {UNTIL}EXPR 3)
(EQ (CADDR {UNTIL}EXPR)
(CADR ARGS]
(CAR {UNTIL}EXPR))
(T (LIST (QUOTE LAMBDA)
ARGS {UNTIL}EXPR]
(RETURN (COND
((OR {OLD} (NEQ {FINALLY}EXPR T))
(MAKESUBST I.V. TEM1)
(* OLD on means that I.V. is going to be used later on. Thus, we set up to substitute TEM1 for I.V.
later, and return I.V. now)
(RETURN (MKAND I.V. {FINALLY}EXPR)))
(T TEM1)))
DOPROG
(RETURN (BQUOTE (PROG , [COND
((NOT {OLD})
(LIST (LIST I.V. {ON}VAR]
,@
[COND
({OLD} (BQUOTE ((SETQ , (BINDVAR I.V.)
, {ON}VAR]
$$SOMELP
(COND
(, (NEGATE {UNTIL}EXPR)
(COND
((LISTP , I.V.)
(SETQ , I.V. (CDR , I.V.))
(GO $$SOMELP)))
(RETURN))
(T (RETURN , {FINALLY}EXPR])
(QLISTP
[LAMBDA (X)
(LIST (QUOTE LISTP)
X])
(QNCONC
[LAMBDA (EXPR1 EXPR2) (* lmm: 17 MAY 75 417)
(COND
((NULL EXPR2)
EXPR1)
((EQ (CAR (LISTP EXPR1))
(QUOTE LIST))
(for Y in (REVERSE (CDR EXPR1)) do (SETQ EXPR2 (LIST (QUOTE CONS)
Y EXPR2)))
EXPR2)
((AND (EQ (CAR (LISTP EXPR2))
(QUOTE LIST))
(NULL (CDDR EXPR2)))
(LOOKLIST (QUOTE NCONC1)
EXPR1
(CADR EXPR2)))
(T (LOOKLIST (QUOTE NCONC)
EXPR1 EXPR2])
)
(DEFINEQ
(PATERR
[LAMBDA (MSG AT)
(LISPXPRIN1 (SELECTQ MSG
(BACKTRACK "This pattern contains an empty test after a -- or $")
(CLISP
"The pattern matcher is confused by what it thinks is CLISP
within a pattern - please recode this patNIL ")
(BADNOT "Cannot negate a non-element pattern")
(TWO! "Two !'s in a row")
(BAD* "invalid *")
(BAD# "invalid #")
(BADELT "Pattern item not atom or list ")
(NOWITH "no WITH")
(AMBIG "ambiguous pattern")
(!AT "!atom in middle of pattern")
(OR MSG "bad pattern"))
T)
(LISPXTERPRI T)
(COND
(AT (LISPXPRIN1 " at: " T)
(LISPXPRINT AT T T)))
(LISPXPRIN1 " in: " T)
(LISPXPRINT MATCHEXPRESSION T T)
(ERROR!])
(PATHELP
[LAMBDA (MESS1 MESS2)
(LISPXPRIN1 "error in Pattern Match" T)
(LISPXTERPRI T)
(HELP MESS1 MESS2])
(LOOKLIST
[LAMBDA (FN ARG ARG')
(LIST (LOOK FN ARG ARG')
ARG ARG'])
(VALUELOOKUP
[LAMBDA (VAR) (* lmm: 25-FEB-76 2 2)
(COND
(LOCALDECLARATION (CLISPLOOKUP0 VAR (CADR MATCHEXPRESSION)
NIL LOCALDECLARATION NIL (QUOTE VALUE)))
(T (GETATOMVAL VAR])
(LOOK
[LAMBDA (FN ARG ARG')
(PROG (CLASS CLASSDEF (LISPFN (OR (GETP FN (QUOTE LISPFN))
FN)))
(RETURN (COND
([AND LOCALDECLARATION (SETQ CLASSDEF (GETP FN (QUOTE CLISPCLASSDEF]
(CLISPLOOKUP0 FN ARG ARG' LOCALDECLARATION LISPFN (GETP FN (QUOTE CLISPCLASS))
CLASSDEF))
(T LISPFN])
)
(DEFINEQ
(MKAND2
[LAMBDA (EXPR1 EXPR2) (* lmm "10-AUG-78 23:00")
(* If the two expressions when ANDed, can be simplified,
return the simplified expression otherwise NIL)
(PROG (TEM TEM2)
(RETURN
(COND
((EQ EXPR1 T)
EXPR2)
((EQ EXPR2 T)
EXPR1)
((EQUALUNCROP EXPR1 EXPR2)
EXPR2)
((EQUALUNCROP EXPR2 EXPR1)
EXPR1)
(T (OR (SELECTQ (CAR (LISTP EXPR1))
(LISTP (CHECKSLISTP EXPR1 EXPR2))
[PROGN (* (AND (AND ... X) Y) combine X and Y)
(COND
((SETQ TEM2 (MKAND2 [CAR (SETQ TEM (LAST (LISTP EXPR1]
EXPR2))
(NCONC1 (LDIFF (LISTP EXPR1)
TEM)
TEM2]
[AND (* (AND (AND ... X) Y) combine X and Y)
(COND
((SETQ TEM2 (MKAND2 [CAR (SETQ TEM (LAST (LISTP EXPR1]
EXPR2))
(MKAND [COND
((EQ (CDDR (LISTP EXPR1))
TEM)
(CADR EXPR1))
(T (CONS (QUOTE AND)
(LDIFF (CDR (LISTP EXPR1))
TEM]
TEM2))
(T (APPEND EXPR1 (LIST EXPR2]
(SETQ (AND (EQUALUNCROP (CADR EXPR1)
EXPR2)
(SUBST EXPR1 (CADR EXPR1)
EXPR2)))
NIL)
(SELECTQ (CAR (LISTP EXPR2))
[AND (COND
[(SETQ TEM (MKAND2 EXPR1 (CADR EXPR2)))
(MKAND TEM (COND
((CDDDR EXPR2)
(CONS (QUOTE AND)
(CDDR EXPR2)))
(T (CADDR EXPR2]
(T (CONS (QUOTE AND)
(CONS EXPR1 (CDR EXPR2]
NIL])
(CHECKSLISTP
[LAMBDA (EXPR1 EXPR2) (* lmm "10-AUG-78 18:47")
(* EXPR1 is an expression (LISTP form) -
if (AND EXPR1 EXPR2) can be reduced, return the reduced form which returns the same value)
(COND
((EQUAL (CADR EXPR1)
EXPR2) (* (AND (LISTP X) X) => (LISTP X))
EXPR1)
((NLISTP EXPR2) (* (AND (LISTP X) Y))
NIL)
((SELECTQ (CAR EXPR2)
((MEMB MEMBER ASSOC SASSOC)
(AND (EQUAL (CADDR EXPR2)
(CADR EXPR1))
EXPR2))
((SOME NLEFT LAST NTH EQLENGTH)
(AND (EQUAL (CADR EXPR2)
(CADR EXPR1))
EXPR2))
NIL))
(T (SELECTQ (CAR EXPR2)
[(CAR CDR FNTH FLAST LISTP NLEFT LAST SOME NTH EQLENGTH)
(AND (SETQ EXPR1 (CHECKSLISTP EXPR1 (CADR EXPR2)))
(CONS (CAR EXPR2)
(CONS EXPR1 (CDDR EXPR2]
[(EQUAL EQ STREQUAL EQP)
(AND (CADDR EXPR2)
[OR (SELFQUOTEABLE (CADDR EXPR2))
(AND (EQ (CAR (LISTP (CADDR EXPR2)))
(QUOTE QUOTE))
(CADR (CADDR EXPR2]
(SETQ EXPR1 (CHECKSLISTP EXPR1 (CADR EXPR2)))
(CONS (CAR EXPR2)
(CONS EXPR1 (CDDR EXPR2]
[(FMEMB FASSOC MEMB MEMBER ASSOC SASSOC)
(COND
((SETQ EXPR1 (CHECKSLISTP EXPR1 (CADDR EXPR2)))
(LIST (CAR EXPR2)
(CADR EXPR2)
EXPR1]
NIL])
(EQUALUNCROP
[LAMBDA (EXPR1 EXPR2) (* lmm "10-AUG-78 23:10")
(* predicate (AND EXPR1 EXPR2) = EXPR2 -
i.e. EXPR2 non-NIL implies EXPR1 non-NIL)
(OR (EQUAL EXPR1 EXPR2)
(AND (LISTP EXPR2)
(COND
((GETP (CAR EXPR2)
(QUOTE CROPS))
(EQUALUNCROP EXPR1 (CADR EXPR2)))
(T (SELECTQ (CAR EXPR2)
((CAR CDR NTH NLEFT LAST FLAST FNTH SOME LISTP)
(EQUALUNCROP EXPR1 (CADR EXPR2)))
((MEMB FMEMB MEMBER ASSOC SASSOC FASSOC)
(EQUALUNCROP EXPR1 (CADDR EXPR2)))
[(EQ EQUAL EQP IEQP)
(AND [OR (EQ (CADDR EXPR2)
T)
(NUMBERP (CADDR EXPR2))
(AND (EQ (CAR (LISTP (CADDR EXPR2)))
(QUOTE QUOTE))
(CADR (CADDR EXPR2]
(EQUALUNCROP EXPR1 (CADR EXPR2]
NIL])
)
(DEFINEQ
(PATPARSE
[LAMBDA (PAT)
(OR (LISTP PAT)
(PATHELP "bad input" PAT))
(PROG (DEFAULTLST)
(RETURN (PATPARSE1 PAT])
(PATPARSE1
[LAMBDA (PAT PREFIX) (* DECLARATIONS: UNDOABLE)
(* lmm: "27-JUN-77 12:35")
(PROG (TEM TEM2 TEM3 CARPAT CDRPAT NOTFOUND)
(OR PAT (RETURN))
RETRY
[AND (CDR PAT)
(NLISTP (CDR PAT))
(SETQ PAT (LIST (CAR PAT)
(QUOTE %.)
(CDR PAT] (* Take care of (a . b) by changing it to
(a %. b))
(SETQ CARPAT (CAR PAT))
[AND (EQ CARPAT COMMENTFLG)
(NULL NORMALCOMMENTSFLG)
(SETQ CARPAT (CAR (GETCOMMENT PAT]
(SETQ CDRPAT (CDR PAT))
[COND
[(LISTP CARPAT)
(SELECTQ (CAR CARPAT)
(*ANY* [SETQ CARPAT (CONS (CAR CARPAT)
(PROG ((TOPPAT CARPAT))
(RETURN (PATPARSE1 (CDR CARPAT]
(OR (EVERY CARPAT (FUNCTION SIMPLELT?))
(PATERR "*ANY*/*EVERY* construct too compicated" PAT)))
(QUOTE (* This is so (--(QUOTE A)
--)
means
(-- ' A --)
; this kludge is necessary now since DWIMIFY1B sometimes parses the
' A into (QUOTE A))
[COND ((NOT (ATOM (CADR CARPAT)))
(/RPLNODE PAT (QUOTE ')
(CONS (CADR CARPAT)
CDRPAT)))
(T (/RPLACA PAT (PACK (LIST (QUOTE ')
(CADR CARPAT]
(GO RETRY))
[LAMBDA (* (-- (LAMBDA (X) --) --) means
(-- &@ (LAMBDA (X) --)))
(/ATTACH (QUOTE &@)
PAT)
(GO RETRY]
(PROGN (* Otherwise, it's a sub-pattern)
(SETQ CARPAT (MAKESUBPAT (PROG ((TOPPAT CARPAT))
(RETURN (PATPARSE1 CARPAT]
((NOT (LITATOM CARPAT)) (* Strings and numbers parse to themselves)
(OR (STRINGP CARPAT)
(NUMBERP CARPAT)
(PATERR (QUOTE BADELT)
CARPAT)))
(T (SELECTQ CARPAT
((T NIL & -- $))
($$ (SETQQ CARPAT --))
($1 (SETQQ CARPAT &))
[($2 $3 $4 $5 $6 $7 $8 $9)
(SETQ CARPAT (CONS (QUOTE $=)
(NTHCHAR CARPAT 2]
((== = $> $< $=)
(SETQ TEM2 (PATGETEXPR CDRPAT PAT))
[SETQ CARPAT (COND
((AND (EQ CARPAT (QUOTE $=))
(EQ (CAR TEM2)
1))
(QUOTE &))
(T (CONS CARPAT (CAR TEM2]
(SETQ CDRPAT (CDR TEM2)))
[(! %.)
(SETQ TEM2 (PATPARSE1 CDRPAT))
(RETURN (CONS (MAKE!PAT (CAR TEM2)
TEM2 PAT PREFIX)
(CDR TEM2]
[~ (SETQ TEM2 (PATPARSE1 CDRPAT))
(RETURN (CONS (NEGATEPAT (CAR TEM2)
PAT)
(CDR TEM2]
(' (SETQ CARPAT (CONS (QUOTE ')
(CAR CDRPAT)))
(SETQ CDRPAT (CDR CDRPAT)))
(COND
((SETQ TEM (PATUNPACK PAT))
(SETQ PAT TEM) (* Now, either we have a "DEFAULT" condition, or else a
var infix condition)
(GO RETRY))
(T (SETQ NOTFOUND PAT]
(* By now, CARPAT is set to the parsing of the first thing in PAT; and CDRPAT is the appropriate tail;
want to check for infix operators; if NOTFOUND is non-nil, then CARPAT was an atom which wasn't parseable as a
pattern; might be a variable if followed by a ← or a # or a *)
REINFIX
[COND
((AND CDRPAT (NLISTP CDRPAT))
(SETQ CDRPAT (LIST (QUOTE %.)
CDRPAT]
(COND
((SETQ TEM (AND CDRPAT (FASSOC (CAR CDRPAT)
PATTERNREPLACEOPRS)))
[COND
[NOTFOUND
(* CARPAT is not a pattern, and followed by a ←; want to know if the next thing is a pattern or something else;
it is assumed that var←pattern is meant; I could change it to mean pat←var)
[COND
((FMEMB CARPAT #LIST))
((STRPOS "#" CARPAT 1 NIL 1)
(SETQ #LIST (CONS CARPAT #LIST]
(* Check if a # type variable)
(SETQ TEM3 (PATPARSE1 (CDR CDRPAT)
CDRPAT))
(RETURN (CONS (CONS (CADR TEM)
(CONS CARPAT (CAR TEM3)))
(CDR TEM3]
(T (SETQ CARPAT (CONS (CADDR TEM)
(CONS [CAR (SETQ CDRPAT (PATGETEXPR (CDR CDRPAT]
CARPAT)))
(SETQ CDRPAT (CDR CDRPAT]
(GO REINFIX))
(NOTFOUND (COND
((AND (EQ (NTHCHAR (CAR CDRPAT)
1)
(QUOTE ←))
(IGREATERP (NCHARS (CAR CDRPAT))
1))
(/RPLNODE CDRPAT (QUOTE ←)
(CONS (MKATOM (SUBSTRING (CAR CDRPAT)
2 -1))
(CDR CDRPAT)))
(GO REINFIX)))
(COND
(PREFIX (PATERR (COND
((STRPOSL CLISPCHARRAY (CAR PAT))
(QUOTE CLISP))
(T (QUOTE AMBIG)))
PAT)))
(SETQ PAT (PARSEDEFAULT PAT NIL PREFIX))
(SETQ NOTFOUND)
(GO RETRY))
((EQ (CAR CDRPAT)
(QUOTE @))
(SETQ CDRPAT (OR (PATUNPACKINFIX1 (CDR CDRPAT))
(CDR CDRPAT)))
(SETQ CARPAT (CONS (QUOTE @)
(CONS (PATGETFNNAME CDRPAT)
CARPAT)))
(SETQ CDRPAT (CDR CDRPAT))
(GO REINFIX))
((SETQ TEM (PATUNPACKINFIX CDRPAT))
(SETQ CDRPAT TEM)
(GO REINFIX)))
(RETURN (CONS CARPAT (PATPARSE1 CDRPAT])
(PATUNPACKINFIX1
[LAMBDA (L)
(PATPARSEAT L PATTERNINFIXES1])
(PARSEDEFAULT
[LAMBDA (PAT LOCALVARDEFAULT PREFIX) (* lmm "22-MAY-80 21:37")
(* Turns PAT:1 (which is a LITATOM) into the "DEFAULT" pattern -
I.e. PAT:1 couldn't be parsed as a pattern -
It is assumed that the default for an atom is an element pattern)
(OR (AND (LITATOM (CAR PAT))
(NEQ (CAR PAT)
T)
(CAR PAT))
(PATHELP "MAKEDEFAULT" (CAR PAT)))
(PROG (SMASHFLG NEWPAT)
(COND
((FMEMB (CAR PAT)
DEFAULTLST) (* Second occurance of a "DEFAULT" is defaulted to =)
(SETQQ LOCALVARDEFAULT =))
([COND
((STRPOS "#" (CAR PAT)
1 NIL 1)
(OR (NUMBERP (SUBATOM (CAR PAT)
2 -1))
(PATERR (QUOTE BAD#)
PAT)))
((STRPOS "*" (CAR PAT))
(OR (EQ (CAR PAT)
(QUOTE *))
(PATERR (QUOTE BAD*)
PAT] (* #n is defaulted to ← the first time)
(SETQQ LOCALVARDEFAULT SETQ))
((AND (NLISTP (CAR PAT))
(STRPOSL CLISPCHARRAY (CAR PAT)))
(PATERR (QUOTE CLISP)
PAT)))
RETRY
[SETQ NEWPAT (SELECTQ (OR LOCALVARDEFAULT (AND (NLISTP VARDEFAULT)
VARDEFAULT))
[(← SETQ SET)
(SETQ DEFAULTLST (CONS (CAR PAT)
DEFAULTLST))
(CONS (CAR PAT)
(CONS (QUOTE ←)
(CONS (QUOTE &)
(CDR PAT]
[(QUOTE ')
(COND
(SMASHFLG (/ATTACH (QUOTE ')
PAT))
(T (RETURN (CONS (QUOTE ')
PAT]
[(= EQUAL)
(COND
(SMASHFLG (/ATTACH (QUOTE =)
PAT))
(T (RETURN (CONS (QUOTE =)
PAT]
[(== EQ)
(COND
(SMASHFLG (/ATTACH (QUOTE ==)
PAT))
(T (RETURN (CONS (QUOTE ==)
PAT]
[(@ APPLY*)
(COND
(SMASHFLG (/ATTACH (QUOTE $1@)
PAT))
(T (RETURN (CONS (QUOTE $1)
(CONS (QUOTE @)
PAT]
(PROGN (SETQ SMASHFLG T)
[SETQ LOCALVARDEFAULT (COND
(LOCALVARDEFAULT (PATERR (COND
(VARDEFAULT
"invalid PATTERNVARDEFAULT")
(T (QUOTE AMBIG)))
PAT))
((EQ 1 (GETP (CAR PAT)
(QUOTE NARGS)))
(SETQ SMASHFLG)
(QUOTE @))
((VARCHECK (CAR PAT)
T T T)
(QUOTE =))
((LISTP VARDEFAULT)
(CAR VARDEFAULT))
(T (QUOTE ?]
(GO RETRY]
(COND
(SMASHFLG (/RPLNODE2 PAT NEWPAT)
(RETURN PAT))
(T (RETURN NEWPAT])
(VARCHECK
[LAMBDA (VAR NOMESSFLG SPELLFLG PROPFLG) (* Checks if VAR is really a variable -
Used by MAKEDEFAULT to avoid bad parsings)
(OR (AND (LITATOM VAR)
(OR (FMEMB VAR VARS)
(NEQ (EVALV VAR)
(QUOTE NOBIND)))
VAR)
(AND (NOT NOMESSFLG)
(ERROR VAR "NOT A VARIABLE" T])
(PATUNPACK
[LAMBDA (PAT) (* lmm "22-MAY-80 21:37")
(* THIS WOULD BE SIMPLER IF THERE WERNT THINGS LIKE $N AROUND -- THIS FUNCTION UNPACKS (CAR PAT) ALONG THE LINES OF
PATTERN OPERATORS -
I'LL MAKE IT SIMPLER BY ASSUMING THAT THINGS ARE OK (I.E. WILL UNPACK) (AND (STRPOSL PATTERNCHARRAY
(CAR PAT)) (PROG ((CHARS (UNPACK (CAR PAT))) RESULTS) RETRY (for CHR on CHARS do (for X in PATCHRLST bind TAIL do
(SETQ TAIL CHR) (COND ((for Z in (CDR X) always (COND ((EQ Z (CAR TAIL)) (SETQ TAIL (CDR TAIL)) T)))
(* CHARS IS (... PATCHRSTRING ...); WE TAKE AND PUT ON RESULTS THE UNPACKING OF THE FIRST AND REST)
(SETQ RESULTS (NCONC RESULTS (COND ((NEQ CHR CHARS) (LIST (PACK (LDIFF CHARS CHR)))) (T NIL))
(LIST (CAR X)))) (SETQ CHARS TAIL) (GO RETRY))))) (RETURN (AND RESULTS (NCONC1 RESULTS (PACK CHARS))
(RETURN RESULTS))))))
(PATPARSEAT PAT PATCHARS])
(PATUNPACKINFIX
[LAMBDA (L)
(PATPARSEAT L PATTERNINFIXES1])
(PATGETFNNAME
[LAMBDA (L) (* wt: "14-JUN-78 10:59")
(OR (LISTP (CAR L))
(FGETD (CAR L))
(FIXSPELL (CAR L)
70 SPELLINGS2 T L (FUNCTION GETD)
NIL NIL T)
(FIXSPELL (CAR L)
70 USERWORDS T L (FUNCTION GETD)
T))
(CAR L])
(PATGETEXPR
[LAMBDA (L UP) (* lmm: "19-SEP-76 23:26:14")
(OR L (PATERR "missing an expression" UP))
(SETQ L (OR (PATUNPACKINFIX L)
L))
[COND
((LISTP (CAR L))
(PROG ((VARS (APPEND #LIST VARS)))
(RETURN (DWIMIFY0? (CAR L)
(CAR L)
NIL NIL NIL FAULTFN]
(for X in #LIST when (AND (NOT (FMEMB X #LISTUSED))
(FINDIN1 X (CAR L)))
do (SETQ #LISTUSED (CONS X #LISTUSED)))
L])
(PATPARSEAT
[LAMBDA (PAT CHRS) (* lmm "22-MAY-80 21:38")
(* Breaks apart (CAR PAT) if possible, replaces the parsing into the beginning of PAT ; otherwise return NIL if
can't -
CHRS is a list of args as if to STRPOS, i.e. check (STRPOS X:1 PAT:1 1 NIL X:2) for X in CHRS -
X:1 is the char list, X:2 is ANCHOR)
(PROG (TEM DONEANYTHING LST POS)
(OR (AND (NLISTP (CAR PAT))
(STRPOSL PATTERNCHARRAY (CAR PAT)))
(RETURN))
(SETQ LST (UNPACK (CAR PAT)))
LP (COND
((NULL CHRS)
(RETURN))
((EQ (CADDR (CAR CHRS))
(CAR PAT))
(RETURN))
([NOT (SETQ POS (COND
[(NULL (CADAR CHRS))
(find X on LST suchthat (for Z in (CAAR CHRS) as ZZ in X
always (EQ Z ZZ]
((for Z in (CAAR CHRS) as ZZ in LST always (EQ Z ZZ))
LST]
(SETQ CHRS (CDR CHRS))
(GO LP))) (* Found one -
POS is now the tail of LST which begins with one of the operators)
[SETQ PAT (CONS (CAR PAT)
(COND
([SETQ TEM (FNTH POS (ADD1 (FLENGTH (CAAR CHRS]
(CONS (PACK TEM)
(CDR PAT)))
(T (CDR PAT]
[SETQ TEM (COND
([AND TEM (EQ (CADDR (CAR CHRS))
(QUOTE $))
(NOT (FMEMB (CAR TEM)
(QUOTE (← @ = < >]
(QUOTE $=))
(T (CADDR (CAR CHRS]
(COND
[(NEQ POS LST)
(RPLNODE PAT (PACKLDIFF LST POS)
(CONS TEM (CDR PAT]
(T (FRPLACA PAT TEM)))
(RETURN PAT])
(MAKE!PAT
[LAMBDA (PATELT PATALL REALPAT PREFIX)
(COND
((AND (EQ (CAR REALPAT)
(QUOTE !))
(EQ PATELT (CAR PATALL))
(OR (EQ (CAR PATELT)
(QUOTE ←))
(EQ (CAR PATELT)
(QUOTE <-)))
(NOT (FMEMB (CADR PATELT)
DEFAULTLST))) (* Change PATALL to ((← var ! subpat %.
all of it)) from ((← var . part1) part2))
[FRPLACD (CDR PATELT)
(MAKE!PAT (MAKESUBPAT (CONS (CDDR PATELT)
(CDR PATALL]
(FRPLACD PATALL NIL)
PATELT)
(T (OR (COND
((NLISTP PATELT)
(SELECTQ PATELT
(& (QUOTE $))
(($ --)
(QUOTE $))
NIL))
(T (SELECTQ (CAR PATELT)
(! (PATERR (QUOTE TWO!)
PATELT))
((← <- % -> @)
(FRPLACD (CDR PATELT)
(MAKE!PAT (CDDR PATELT)))
PATELT)
[* (CONS (CAR PATELT)
(MAKE!PAT (CDR PATELT]
(SUBPAT (AND (NULL (CDDR PATELT))
(NOT (ELT? (CADR PATELT)))
(CADR PATELT)))
($= PATELT)
NIL)))
(CONS (QUOTE !)
PATELT])
(MAKESUBPAT
[LAMBDA (PATLST)
(COND
((NULL PATLST)
NIL)
([OR (EQUAL PATLST (QUOTE (--)))
(EQUAL PATLST (QUOTE ($]
(QUOTE &))
(T (CONS (QUOTE SUBPAT)
PATLST])
(NEGATEPAT
[LAMBDA (PE REALPAT)
(PROG NIL
[COND
((NLISTP PE)
(SELECTQ PE
((& $)
(PATERR "Cannot negate this type of pattern" PE))
T))
(T (SELECTQ (CAR PE)
((= == ' SUBPAT))
[(← % <- ->)
(RETURN (CONS (CAR PE)
(CONS (CADR PE)
(NEGATEPAT (CDDR PE]
(@)
(PATERR (QUOTE BADNOT)
REALPAT]
(RETURN (CONS (QUOTE ~)
PE])
(PACKLDIFF
[LAMBDA (LST1 LST2)
(PROG (TEM1 TEM2)
(FRPLACD (OR (SETQ TEM1 (NLEFT LST1 1 LST2))
(HELP))
NIL)
(RETURN (PROG1 (PACK LST1)
(FRPLACD TEM1 TEM2])
)
(RPAQQ PATCHARS ((($ <)
T $<)
(($ >)
T $>)
(($ =)
T $=)
((')
T ')
((!)
T !)
((= =)
T ==)
((=)
T =)
((~)
T ~)
((< -)
NIL <-)
((@)
NIL @)
((←)
NIL ←)
(($)
T $)))
(RPAQQ PATTERNINFIXES (((←)
T ←)
((< -)
T <-)
((@)
T @)))
(RPAQQ PATTERNINFIXES1 (((←)
NIL ←)
((< -)
NIL <-)
((@)
NIL @)))
(RPAQQ PATTERNREPLACEOPRS ((← ← %)
(←← <- ->)
(←!!←!← ← %)
(<- <- ->)))
(RPAQQ PATTERNITEMS ((&)
(--)
($$ --)
(T)
(NIL)
(&)
(--)
($)
($1 &)
($2 ($= . 2))
($3 ($= . 3))
($4 ($= . 4))
($5 ($= . 5))
($6 ($= . 6))))
(RPAQQ NEVERNILFUNCTIONS (CONS LIST QUOTE ABS ADD1 SUB1 CONCAT REMAINDER FREMAINDER IREMAINDER LOGOR
LOGAND LOGXOR))
(RPAQQ PATNONNILFUNCTIONS (GETD NUMBERP STRINGP ZEROP LISTP SMALLP))
(RPAQ PATTERNCHARRAY [MAKEBITTABLE (NCONC (MAPCAR PATCHARS (QUOTE CAAR))
(MAPCAR PATTERNITEMS (QUOTE CAR])
(RPAQQ PATGENSYMVARS (GENSYMVARS: $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15
$$16 $$17))
(RPAQQ PATVARDEFAULT =)
(RPAQQ MAXCDDDDRS 5)
(RPAQQ PATCHECKLENGTH T)
(RPAQ PATLISTPCHECK (EQ (QUOTE VAX)
(SYSTEMTYPE)))
(RPAQQ PATVARSMIGHTBENIL T)
(RPAQQ PATCHARS ((($ <)
T $<)
(($ >)
T $>)
(($ =)
T $=)
((')
T ')
((!)
T !)
((= =)
T ==)
((=)
T =)
((~)
T ~)
((< -)
NIL <-)
((@)
NIL @)
((←)
NIL ←)
(($)
T $)))
(RPAQQ PATTERNINFIXES (((←)
T ←)
((< -)
T <-)
((@)
T @)))
(RPAQQ PATTERNINFIXES1 (((←)
NIL ←)
((< -)
NIL <-)
((@)
NIL @)))
(RPAQQ PATTERNREPLACEOPRS ((← ← %)
(←← <- ->)
(←!!←!← ← %)
(<- <- ->)))
(RPAQQ PATTERNITEMS ((&)
(--)
($$ --)
(T)
(NIL)
(&)
(--)
($)
($1 &)
($2 ($= . 2))
($3 ($= . 3))
($4 ($= . 4))
($5 ($= . 5))
($6 ($= . 6))))
(RPAQQ NEVERNILFUNCTIONS (CONS LIST QUOTE ABS ADD1 SUB1 CONCAT REMAINDER FREMAINDER IREMAINDER LOGOR
LOGAND LOGXOR))
(RPAQQ PATNONNILFUNCTIONS (GETD NUMBERP STRINGP ZEROP LISTP SMALLP))
(RPAQQ SIMPLE.PREDICATES (LISTP LITATOM NLISTP CAR CDR NULL))
(RPAQ PATTERNCHARRAY [MAKEBITTABLE (NCONC (MAPCAR PATCHARS (QUOTE CAAR))
(MAPCAR PATTERNITEMS (QUOTE CAR])
(RPAQQ PATGENSYMVARS (GENSYMVARS: $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15
$$16 $$17))
(OR (BOUNDP (QUOTE MATCHSTATS))
(SETQ MATCHSTATS))
(RPAQQ PATVARDEFAULT =)
(RPAQQ MAXCDDDDRS 5)
(RPAQQ PATCHECKLENGTH T)
(RPAQQ PATLISTPCHECK NIL)
(RPAQQ PATVARSMIGHTBENIL T)
(RPAQQ MATCHBLOCKS ((MATCHBLOCK (ENTRIES MAKEMATCH)
(GLOBALVARS PATCHARS MAXCDDDDRS PATNONNILFUNCTIONS PATGENSYMVARS
PATTERNREPLACEOPRS PATTERNINFIXES1 PATTERNCHARRAY
NEVERNILFUNCTIONS MATCHSTATS SIMPLE.PREDICATES USERWORDS
SPELLINGS2 CLISPCHARRAY NORMALCOMMENTSFLG COMMENTFLG)
(LOCALFREEVARS WATCHPOSTPONELST SUBLIST INASOME CHECKINGLENGTH WMLST
LASTEFFECTCANBENIL POSTPONEDSETQS MUSTRETURN BOUNDVARS
BOUNDVALS GENSYMVARLIST SKIPEDLEN ZLENFLG
LOCALDECLARATION MATCHEXPRESSION MATCHEFFECTS
CHECKLENGTH #LIST #LISTUSED PATVARSNIL POSTPONEDRPLACS
LISTPCHECK DEFAULTLST VARDEFAULT)
(SPECVARS EXPR FAULTFN VARS CLISPCHANGE)
MAKEMATCH QMATCHSUBPAT QMATCHWM QMATCH$ QMATCH! QMATCH$= QMATCHELT1
QMATCHELT SIMPLEFN DOSIDE CHECKSETQ DOREPLACE DOREPLACE1 PATLEN $?
ELT? SIMPLELT? ARB? NULLPAT? NILPAT CANMATCHNIL CANMATCHNILLIST
REPLACEIN EASYTORECOMPUTE GENSYML MAKESUBST DOSUBST DOSUBST1 SUBSTVAR
BINDVAR SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH PATNARGS QNLEFT QNCONC
QNOT QNULL QNOT1 QNOTLESSPLENGTH QNTH QOR QPLUS QREPLACE MKAND QCAR
QCDR QEQ QEQLENGTH QEQUAL QLAST QAPPLY* QLDIFF QFOR QLISTP PATERR
PATHELP LOOKLIST VALUELOOKUP LOOK MKAND2 CHECKSLISTP EQUALUNCROP
PATPARSE PATPARSE1 PATUNPACKINFIX1 PARSEDEFAULT VARCHECK PATUNPACK
PATUNPACKINFIX PATGETFNNAME PATGETEXPR PATPARSEAT MAKE!PAT MAKESUBPAT
NEGATEPAT PACKLDIFF)))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: MATCHBLOCK (ENTRIES MAKEMATCH)
(GLOBALVARS PATCHARS MAXCDDDDRS PATNONNILFUNCTIONS PATGENSYMVARS PATTERNREPLACEOPRS
PATTERNINFIXES1 PATTERNCHARRAY NEVERNILFUNCTIONS MATCHSTATS SIMPLE.PREDICATES
USERWORDS SPELLINGS2 CLISPCHARRAY NORMALCOMMENTSFLG COMMENTFLG)
(LOCALFREEVARS WATCHPOSTPONELST SUBLIST INASOME CHECKINGLENGTH WMLST LASTEFFECTCANBENIL
POSTPONEDSETQS MUSTRETURN BOUNDVARS BOUNDVALS GENSYMVARLIST SKIPEDLEN ZLENFLG
LOCALDECLARATION MATCHEXPRESSION MATCHEFFECTS CHECKLENGTH #LIST #LISTUSED
PATVARSNIL POSTPONEDRPLACS LISTPCHECK DEFAULTLST VARDEFAULT)
(SPECVARS EXPR FAULTFN VARS CLISPCHANGE)
MAKEMATCH QMATCHSUBPAT QMATCHWM QMATCH$ QMATCH! QMATCH$= QMATCHELT1 QMATCHELT SIMPLEFN DOSIDE
CHECKSETQ DOREPLACE DOREPLACE1 PATLEN $? ELT? SIMPLELT? ARB? NULLPAT? NILPAT CANMATCHNIL
CANMATCHNILLIST REPLACEIN EASYTORECOMPUTE GENSYML MAKESUBST DOSUBST DOSUBST1 SUBSTVAR BINDVAR
SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH PATNARGS QNLEFT QNCONC QNOT QNULL QNOT1 QNOTLESSPLENGTH
QNTH QOR QPLUS QREPLACE MKAND QCAR QCDR QEQ QEQLENGTH QEQUAL QLAST QAPPLY* QLDIFF QFOR QLISTP
PATERR PATHELP LOOKLIST VALUELOOKUP LOOK MKAND2 CHECKSLISTP EQUALUNCROP PATPARSE PATPARSE1
PATUNPACKINFIX1 PARSEDEFAULT VARCHECK PATUNPACK PATUNPACKINFIX PATGETFNNAME PATGETEXPR
PATPARSEAT MAKE!PAT MAKESUBPAT NEGATEPAT PACKLDIFF)
]
(DECLARE: DONTCOPY (PUTPROPS MATCH COPYRIGHT ("Xerox Corporation" 1982)))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2049 27294 (MAKEMATCH 2059 . 7062) (QMATCHSUBPAT 7064 . 7523) (QMATCHWM 7525 . 10667) (
QMATCH$ 10669 . 17230) (QMATCH! 17232 . 20307) (QMATCH$= 20309 . 21858) (QMATCHELT1 21860 . 22824) (
QMATCHELT 22826 . 23977) (SIMPLEFN 23979 . 24306) (DOSIDE 24308 . 25359) (CHECKSETQ 25361 . 25797) (
DOREPLACE 25799 . 26351) (DOREPLACE1 26353 . 27292)) (27295 31483 (PATLEN 27305 . 28295) ($? 28297 .
28377) (ELT? 28379 . 28762) (SIMPLELT? 28764 . 28919) (ARB? 28921 . 29143) (NULLPAT? 29145 . 29257) (
NILPAT 29259 . 29327) (CANMATCHNIL 29329 . 30764) (CANMATCHNILLIST 30766 . 30938) (REPLACEIN 30940 .
31481)) (31484 38282 (EASYTORECOMPUTE 31494 . 31952) (GENSYML 31954 . 32147) (MAKESUBST 32149 . 32486)
(DOSUBST 32488 . 33275) (DOSUBST1 33277 . 37040) (SUBSTVAR 37042 . 37191) (BINDVAR 37193 . 37338) (
SELFQUOTEABLE 37340 . 37471) (FINDIN0 37473 . 37713) (FINDIN1 37715 . 37916) (DOWATCH 37918 . 38208) (
PATNARGS 38210 . 38280)) (38283 45054 (QNLEFT 38293 . 38822) (QNOT 38824 . 38877) (QNULL 38879 . 38934
) (QNOT1 38936 . 39339) (QNOTLESSPLENGTH 39341 . 39433) (QNTH 39435 . 39931) (QOR 39933 . 40091) (
QPLUS 40093 . 40260) (QREPLACE 40262 . 40348) (MKAND 40350 . 40507) (QCAR 40509 . 40561) (QCDR 40563
. 40615) (QEQ 40617 . 40820) (QEQLENGTH 40822 . 41130) (QEQUAL 41132 . 41792) (QLAST 41794 . 41863) (
QAPPLY* 41865 . 42044) (QLDIFF 42046 . 42189) (QFOR 42191 . 44500) (QLISTP 44502 . 44558) (QNCONC
44560 . 45052)) (45055 46596 (PATERR 45065 . 45787) (PATHELP 45789 . 45913) (LOOKLIST 45915 . 45999) (
VALUELOOKUP 46001 . 46257) (LOOK 46259 . 46594)) (46597 50662 (MKAND2 46607 . 48285) (CHECKSLISTP
48287 . 49735) (EQUALUNCROP 49737 . 50660)) (50663 64387 (PATPARSE 50673 . 50816) (PATPARSE1 50818 .
56017) (PATUNPACKINFIX1 56019 . 56093) (PARSEDEFAULT 56095 . 58670) (VARCHECK 58672 . 59017) (
PATUNPACK 59019 . 60006) (PATUNPACKINFIX 60008 . 60081) (PATGETFNNAME 60083 . 60380) (PATGETEXPR 60382
. 60890) (PATPARSEAT 60892 . 62473) (MAKE!PAT 62475 . 63543) (MAKESUBPAT 63545 . 63743) (NEGATEPAT
63745 . 64181) (PACKLDIFF 64183 . 64385)))))
STOP