perm filename MATCH[PAT,LMM]4 blob sn#085839 filedate 1974-02-03 generic text, type T, neo UTF8
(FILECREATED "16-JAN-74  3:17:00" MATCH

     changes to:  MAKEMATCH,'MATCHWM,'MATCHELT1,'MATCHELT,PATPARSE1,
CANMATCHNIL,DOSUBST1,FORMEXPAND,VALUELOOKUP,PATCHARS,PATERR,PATLEN,
REPLACED,'PROGN,MATCHVARS,SIMPLELT?

     previous date: "10-JAN-74 08:11:47")


  (LISPXPRINT (QUOTE MATCHVARS)
              T)
  [RPAQQ MATCHVARS
         ((FNS MAKEMATCH 'MATCHTOP 'MATCHSUBPAT 'MATCHWM 'MATCHWMFUNARG 
               CHECKSETQ 'MATCHELT1 'MATCHELT)
          (FNS PATPARSE PATPARSE1 PARSEDEFAULT PATUNPACK PATUNPACKINFIX 
               PATGETFNNAME PATGETEXPR PATPARSEAT MAKE!PAT MAKESUBPAT 
               NEGATEPAT PACKLDIFF)
          (FNS SKIP$I SKIP$ANY PATLEN $? ELT? SIMPLELT? ARB? NULLPAT? 
               NILPAT CANMATCHNIL CANMATCHNILLIST REPLACEIN REPLACED)
          (FNS EASYTORECOMPUTE TEST# NEVERNIL FULLEXPANSION GENSYML 
               MAKESUBST MAKESUBST3 MAKESUBST0 MAKESUBST1 DOSUBST 
               DOSUBST1 FORMEXPAND POSTPONEDREPLACE POSTPONEDSETQ 
               SUBSTVAR BOUNDVAR BINDVAR SELFQUOTEABLE FINDIN0 FINDIN1 
               DOWATCH UNCROP PATNARGS UNCDR CHECKEASYVAR)
          (FNS 'NLEFT 'NOT 'NULL 'NOT1 'NOTLESSPLENGTH 'NTH 'OR 'PLUS 
               'REPLACE 'SETQ 'AND 'AND2 'CAR 'CDR 'EQ 'EQLENGTH 'EQUAL 
               'LAST 'F/L 'APPLY* 'HEADPLOOP 'LDIFF 'PROG 'NCONC 'FOR 
               'PROGN 'LISTP)
          (FNS PATERR PATHELP LOOKLIST VALUELOOKUP LOOK VARCHECK TRUE)
          (BLOCKS (MATCHBLOCK MAKEMATCH 'MATCHTOP 'MATCHSUBPAT 'MATCHWM 
                              'MATCHWMFUNARG CHECKSETQ 'MATCHELT1 
                              'MATCHELT PATPARSE PATPARSE1 PARSEDEFAULT 
                              PATUNPACK PATUNPACKINFIX PATGETFNNAME 
                              PATGETEXPR PATPARSEAT MAKE!PAT MAKESUBPAT 
                              NEGATEPAT PACKLDIFF SKIP$I SKIP$ANY 
                              PATLEN $? ELT? SIMPLELT? ARB? NULLPAT? 
                              NILPAT CANMATCHNIL CANMATCHNILLIST 
                              REPLACEIN REPLACED EASYTORECOMPUTE TEST# 
                              NEVERNIL FULLEXPANSION GENSYML MAKESUBST 
                              MAKESUBST0 MAKESUBST3 MAKESUBST1 DOSUBST 
                              DOSUBST1 FORMEXPAND POSTPONEDREPLACE 
                              POSTPONEDSETQ SUBSTVAR BOUNDVAR BINDVAR 
                              SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH 
                              UNCROP PATNARGS UNCDR CHECKEASYVAR 'NLEFT 
                              'NOT 'NULL 'NOT1 'NOTLESSPLENGTH 'NTH 'OR 
                              'PLUS 'REPLACE 'SETQ 'AND 'AND2 'CAR 'CDR 
                              'EQ 'EQLENGTH 'EQUAL 'LAST 'F/L 'APPLY* 
                              'HEADPLOOP 'LDIFF 'PROG 'NCONC 'FOR 
                              'PROGN 'LISTP PATERR PATHELP LOOKLIST 
                              LOOK VALUELOOKUP VARCHECK TRUE
                              (ENTRIES MAKEMATCH)
                              (GLOBALVARS PATCHARS CRLIST MAXCDDDDRS 
                                          PATNONNILFUNCTIONS 
                                          PATGENSYMVARS PATTERNITEMS 
                                          PATTERNPREFIXES 
                                          PATTERNREPLACEOPRS 
                                          PATTERNINFIXES PATTERNCHARRAY 
                                          NEVERNILFUNCTIONS)
                              (LOCALFREEVARS WATCHPOSTPONELST SUBLIST 
                                             INASOME CHECKINGLENGTH 
                                             WMLST LASTEFFECTCANBENIL 
                                             POSTPONEDEFFECTS 
                                             MUSTRETURN BINDINGS 
                                             GENSYMVARLIST SKIPEDLEN 
                                             ZLENFLG LOCALDECLARATION 
                                             MATCHEXPRESSION 
                                             MATCHEFFECTS CHECKLENGTH 
                                             #LIST PATVARSNILLOOKED 
                                             PATVARSNIL POSTPONEDRPLACS 
                                             LISTPCHECK DEFAULTLST 
                                             VARDEFAULT)
                              (SPECVARS EXPR FAULTFN VARS CLISPCHANGE)
                              (BLKAPPLYFNS TRUE 'MATCHWMFUNARG)))
          (VARS PATCHARS PATTERNINFIXES PATTERNREPLACEOPRS PATTERNITEMS 
                PATTERNPREFIXES CRLIST NEVERNILFUNCTIONS 
                PATNONNILFUNCTIONS
                [PATTERNCHARRAY (MAKEBITTABLE
                                  (NCONC (MAPCAR PATCHARS (QUOTE CAAR))
                                         (MAPCAR PATTERNITEMS
                                                 (QUOTE CAR]
                PATGENSYMVARS)
          (VARS PATTERNVARDEFAULT MAXCDDDDRS (PATTERNCHECKLENGTH T)
                (PATTERNLISTPCHECK NIL)
                (PATVARSMIGHTBENIL T))
          (PROP CLISPCLASS NTH)
          (PROP CLISPCLASSDEF NTH)
          (PROP LISPFN NTH)
          (ADDVARS (DECLWORDS (QUOTE (NTH]
(DEFINEQ

(MAKEMATCH
  [LAMBDA (MATCHEXPRESSION PATTERN)
    (PROG (#LIST BINDINGS SUBLIST (GENSYMVARLIST PATGENSYMVARS)
                 MATCHEFFECTS
                 (LOCALDECLARATION (GETLOCALDEC EXPR FAULTFN))
                 LISTPCHECK VARDEFAULT CHECKLENGTH PATVARSNIL 
                 PATVARSNILLOOKED)
          (SETQ CLISPCHANGE T)
          (SETQ CHECKLENGTH (VALUELOOKUP (QUOTE PATTERNCHECKLENGTH)))
          (SETQ LISTPCHECK (VALUELOOKUP (QUOTE PATTERNLISTPCHECK)))
          (SETQ VARDEFAULT (VALUELOOKUP (QUOTE PATTERNVARDEFAULT)))
          [COND
            (PATTERN (SETQ MATCHEXPRESSION (LIST (QUOTE match)
                                                 MATCHEXPRESSION
                                                 (QUOTE with)
                                                 PATTERN]
          (SETQ MATCHEXPRESSION
            (SELECTQ (CAR MATCHEXPRESSION)
                     ((match MATCH)
                       [SELECTQ (CADDR MATCHEXPRESSION)
                                ((with WITH))
                                (OR (FIXSPELL (CADDR MATCHEXPRESSION)
                                              70
                                              (QUOTE (WITH with))
                                              T
                                              (CDDR MATCHEXPRESSION))
                                    (PATERR (QUOTE NOWITH)
                                            (CDDR MATCHEXPRESSION]
                       ('MATCHTOP
                         (CADR MATCHEXPRESSION)
                         (PROG ((TOPPAT (CADDDR MATCHEXPRESSION)))
                               (PATPARSE TOPPAT))
                         [AND (CDDDDR MATCHEXPRESSION)
                              (PROG ((VARS (APPEND #LIST VARS)))
                                    (DWIMIFY1B (CDR (CDDDDR 
                                                    MATCHEXPRESSION))
                                               MATCHEXPRESSION T NIL 
                                               NIL FAULTFN)
                                    (RETURN (CDR (CDDDDR 
                                                    MATCHEXPRESSION]
                         (EQ (CAR (CDDDDR MATCHEXPRESSION))
                             (QUOTE ->))
                         T))
                     (HELP)))
          (RETURN (COND
                    [BINDINGS ('PROG BINDINGS
                                     (LIST (LIST (QUOTE RETURN)
                                                 MATCHEXPRESSION]
                    (T MATCHEXPRESSION])

('MATCHTOP
  [LAMBDA (VAR PAT CONSTRUCT SMASHFLG RETURNFLG)
    (PROG (POSTPONEDRPLACS POSTPONEDEFFECTS LASTEFFECTCANBENIL 
                           MUSTRETURN WMLST WATCHPOSTPONELST SUBLIST 
                           SAVEDUMMY)

          (* POSTPONEDEFFECTS is the list of side effects 
          postponed -
          LASTEFFECTCANBENIL is a flag which should be set 
          whenever a side effect is postponed 
          (used for determining whether the extra T at the end 
          is necessary) -
          BINDINGS will be list of prog 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 flag 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)


          (SETQ VAR (CHECKEASYVAR (COPY VAR)
                                  PAT))
          (SETQ MATCHEXPRESSION ('MATCHSUBPAT VAR PAT))
          (SETQ SUBLIST (DREVERSE SUBLIST))
          [AND CONSTRUCT SMASHFLG (SETQ CONSTRUCT
                 (LIST (SETQ SAVEDUMMY (CONS (QUOTE DUMMY)
                                             (CONS VAR CONSTRUCT]
          [SETQ MATCHEFFECTS (NCONC (DREVERSE POSTPONEDEFFECTS)
                                    (DREVERSE POSTPONEDRPLACS)
                                    (COND
                                      (CONSTRUCT)
                                      (MUSTRETURN (LIST MUSTRETURN))
                                      ((AND LASTEFFECTCANBENIL
                                            (NULL POSTPONEDRPLACS))
                                        (LIST T]
          (RETURN (PROG1 [DOSUBST (COND
                                    (RETURNFLG ('AND MATCHEXPRESSION
                                                     ('PROGN 
                                                       MATCHEFFECTS)))
                                    (T (CONS MATCHEXPRESSION 
                                             MATCHEFFECTS]
                         (AND SAVEDUMMY
                              (RPLNODE2 SAVEDUMMY
                                        ('REPLACE (CADR SAVEDUMMY)
                                                  ('PROGN (CDDR 
                                                          SAVEDUMMY])

('MATCHSUBPAT
  [LAMBDA (VAR PATELT)
    (PROG ((CHECKINGLENGTH T)
           INASOME)
          (COND
            [LISTPCHECK ('AND ('LISTP VAR)
                              ('MATCHWM VAR PATELT (QUOTE (TRUE]
            (T ('MATCHWM VAR PATELT (QUOTE (TRUE])

('MATCHWM
  [LAMBDA (VAR PAT FN)

          (* 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 (CAR FN) to 
          (the expression giving What-Matched the first 
          pattern element of PAT) and 
          (CDR FN) -
          is non-nil as well. FN can hide side effects as well 
          i.e. FN may say to generate a side effect to be 
          executed if the entire pattern succeeds)


    (PROG (TEM1 TEM2 TAIL ZLENFLG (SKIPEDLEN 0))
                                                (* ZLENFLG and SKIPEDLEN
                                                are set from within 
                                                SKIP$I and SKIP$ANY)
          (COND
            [(NULL PAT)
              (RETURN (OR (NOT CHECKLENGTH)
                          (NOT CHECKINGLENGTH)
                          ('NULL VAR]
            [(NLISTP (CAR PAT))

          (* The only NLISTP patterns are &, $, --, NIL, T, 
          strings and numbers)


              (SELECTQ
                (CAR PAT)
                [($ --)
                  (RETURN
                    (COND
                      ((NULL (CDR PAT))         (* Pattern ends in $ -
                                                What matched is the 
                                                whole thing)
                        (BLKAPPLY* (CAR FN)
                                   VAR
                                   (CDR FN)))
                      (INASOME 

          (* We are within a tail which began with -- or $;
          thus, we should not return the match here but 
          instead, SET the variable INASOME to the match 
          expression here and return T -
          since there is no point in checking this match 
          expression repeatedly)


                               (COND
                                 ((LISTP INASOME)
                                   (PATHELP "INASOME mismatch")))
                               [DOWATCH (SETQ INASOME
                                          (PROG (INASOME)
                                                ('MATCHWM VAR PAT FN]
                               T)
                      [(ARB? (CADR PAT))
                        (COND
                          ((OR (SKIP$ANY (CDDR PAT))
                               (NOT (ZEROP SKIPEDLEN)))

          (* ($ ARB -- }FIXED) I.e. two arb's in a row, 
          followed by something)


                            (PATERR "Two arbitrary segments in a row")))
                                                (* Must mean the second 
                                                is LAST)
                        ('AND ('MATCHWM (SETQ TEM1 (SUBSTVAR
                                            ('LAST VAR)))
                                        (CDR PAT)
                                        (QUOTE (TRUE)))
                              (BLKAPPLY* (CAR FN)
                                         ('LDIFF VAR TEM1)
                                         (CDR FN]
                      [[AND (EQ (CAR FN)
                                (QUOTE TRUE))
                            (PROGN (SETQ TAIL (SKIP$I (CDR PAT)))
                                   (NOT (ZEROP SKIPEDLEN]

          (* Special check here, since might have 
          (... -- $4) or not need any 'NLEFT's)


                        (COND
                          ((OR (NULL TAIL)
                               (NULLPAT? TAIL))
                            (OR (NOT CHECKINGLENGTH)
                                ('NOTLESSPLENGTH VAR SKIPEDLEN)))
                          [(NUMBERP SKIPEDLEN)
                            ('MATCHWM ('NTH VAR (ADD1 SKIPEDLEN))
                                      (CONS (CAR PAT)
                                            TAIL)
                                      (QUOTE (TRUE]
                          (T
                            ('MATCHWM
                              ['CDR (SETQ TEM1
                                      (SUBSTVAR ('NTH VAR ('PLUS 
                                                          SKIPEDLEN 1]
                              (CONS (CAR PAT)
                                    TAIL)
                              (QUOTE (TRUE]
                      [[NILPAT (SETQ TAIL (SKIP$ANY (CDR PAT]
                        (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 (AND (REPLACED (CDR PAT))
                                            (SETQ TEM2 (UNCDR VAR)))
                                       (ZEROP SKIPEDLEN))
                                                (* Check 
                                                var::-skipedlen)
                                    ('CDR (SUBSTVAR
                                            ('NLEFT TEM2 ('PLUS 
                                                          SKIPEDLEN 1)
                                                    NIL ZLENFLG]
                                  (T (SUBSTVAR ('NLEFT VAR SKIPEDLEN 
                                                       NIL ZLENFLG]
                              ('AND (OR (NOT (CANMATCHNILLIST
                                               (CDR PAT)))
                                        TEM1)
                                    ('MATCHWM TEM1 (CDR PAT)
                                              (QUOTE (TRUE)))
                                    (BLKAPPLY* (CAR FN)
                                               ('LDIFF VAR TEM1)
                                               (CDR FN]
                      ([AND (EQ (CAR FN)
                                (QUOTE TRUE))
                            (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
                                          ('MATCHELT
                                            (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]
                              ('MATCHSUBPAT (SUBSTVAR VAR)
                                            PAT)))
                      (T
                        (PROG ({OLD⎇ {FINALLY⎇EXPR {UNTIL⎇EXPR {ON⎇VAR
                                     [INASOME (COND
                                                ((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 (REPLACED (CDR PAT))
                                      (SETQ {ON⎇VAR (UNCDR VAR)))
                                  (SETQ TEM2 ('CDR TEM1)))
                                (T (SETQ {ON⎇VAR VAR)
                                   (SETQ TEM2 TEM1)))
                              [COND
                                (T
                                  [SETQ {UNTIL⎇EXPR
                                    ('MATCHWM TEM2 (CDR PAT)
                                              (QUOTE (TRUE]
                                  (SETQ {FINALLY⎇EXPR
                                    ('AND
                                      (BLKAPPLY* (CAR FN)
                                                 ('LDIFF VAR TEM2)
                                                 (CDR FN))
                                      (OR
                                        [NOT
                                          (NULL
                                            (FMEMB INASOME
                                                   (QUOTE (INASOME
                                                            FASTINASOME]
                                        INASOME]
                              (SETQ {OLD⎇ (EQ (CAR WATCHPOSTPONELST)
                                              (QUOTE FOUND)))
                              (RETURN ('FOR {OLD⎇ TEM1 {ON⎇VAR 
                                            {UNTIL⎇EXPR {FINALLY⎇EXPR
                                            (CANMATCHNILLIST
                                              (CDR PAT]
                (RETURN ('MATCHELT1 VAR PAT FN]
            ((SELECTQ
                (CAAR PAT)
                ((= == ' SUBPAT } *ANY*)

          (* For now, }'s can only refer to = == ' and subpats 
          , i.e. elementary patterns)


                  (RETURN ('MATCHELT1 VAR PAT FN)))
                [$<                             (* This matches a 
                                                segment less that a 
                                                given length)

          (* (FOR {TEM1⎇ ON {VAR⎇ AS {TEM2⎇ FROM {PAT:1::2⎇ TO 
          1 BY -1 DO (IF (MATCHES {TEM1⎇ {PAT::1⎇) THEN 
          (RETURN {FINALLY,SIDES⎇))))


                  (RETURN
                    (COND
                      [(NILPAT (CDR PAT))       (* Pattern ends in --)
                        ('AND ['NULL ('NTH VAR ('PLUS 1 (CDAR PAT]
                              (BLKAPPLY* (CAR FN)
                                         VAR
                                         (CDR FN]
                      (INASOME [DOWATCH (SETQ INASOME
                                          (PROG (INASOME)
                                                (RETURN ('MATCHWM
                                                          VAR PAT FN]
                               T)
                      (T
                        (PROG ((INASOME (QUOTE INASOME)))
                              (SUBPAIR
                                (QUOTE (TEM1 VAR CNT MTCH FINALLY))
                                [LIST
                                  (SETQ TEM1 (GENSYML))
                                  VAR
                                  (CDAR PAT)
                                  ['NOT ('MATCHWM TEM1 (CDR PAT)
                                                  (QUOTE (TRUE]
                                  ('AND (OR (EQ INASOME (QUOTE INASOME))
                                            INASOME)
                                        (BLKAPPLY* (CAR FN)
                                                   ('LDIFF VAR TEM1)
                                                   (CDR FN]
                                (QUOTE
                                  (PROG ((TEM1 VAR)
                                         ($$CNT CNT))
                                    $$RPTLP
                                        (COND
                                          ((IMINUSP (SETQ $$CNT
                                                      (SUB1 $$CNT)))
                                            (RETURN))
                                          [MTCH (COND
                                                  ((LISTP TEM1)
                                                    (SETQ TEM1
                                                      (CDR TEM1))
                                                    (GO $$RPTLP))
                                                  (T (RETURN]
                                          (T (RETURN FINALLY]
                ($>
                  (RETURN
                    ('MATCHWM VAR
                              (CONS (LIST (QUOTE !)
                                          (QUOTE SUBPAT)
                                          (CONS (QUOTE $=)
                                                ('PLUS 1 (CDAR PAT)))
                                          (QUOTE --))
                                    (CDR PAT))
                              FN)))
                [!
                  (RETURN
                    (COND
                      [(NILPAT (CDR PAT))
                        ('AND [COND
                                [(EQ (CADAR PAT)
                                     (QUOTE SUBPAT))

          (* This isn't really a subpat and so don't rebind 
          CHECKINGLENGTH etc as in 'MATCHSUBPAT)


                                  ('MATCHWM VAR (CDDAR PAT)
                                            (QUOTE (TRUE]
                                (T ('MATCHELT VAR (CDAR PAT]
                              (BLKAPPLY* (CAR FN)
                                         VAR
                                         (CDR FN]
                      ((NLISTP (CAR PAT))
                        (PATERR "Invalid '!'" PAT))
                      (T
                        (SELECTQ
                          (CADAR PAT)
                          [=                    (* !=)
                            ('HEADPLOOP VAR (CDDAR PAT)
                                        (SETQ TEM1 (BOUNDVAR))
                                        (CANMATCHNILLIST (CDR PAT))
                                        ('AND (BLKAPPLY* (CAR FN)
                                                         ('LDIFF VAR 
                                                               TEM1)
                                                         (CDR FN))
                                              ('MATCHWM
                                                TEM1
                                                (CDR PAT)
                                                (QUOTE (TRUE]
                          [==(COND
                              ((NULLPAT? (CDR PAT))
                                (PROG ((CHECKLENGTH T))
                                      ('MATCHWM 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))
                                          ('MATCHWM
                                            VAR
                                            (LIST (CAR PAT))
                                            FN)))
                                  (T (PATERR (QUOTE !AT)
                                             (CDAR PAT]
                              (T
                                ('MATCHWM
                                  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
                              [(EQ (CAR FN)
                                   (QUOTE TRUE))
                                ('MATCHWM VAR (APPEND (CDDAR PAT)
                                                      (CDR PAT))
                                          (QUOTE (TRUE]
                              (T
                                (PROG ((WMLST (CONS NIL WMLST)))
                                      (RETURN
                                        ('AND
                                          ('MATCHWM
                                            VAR
                                            [APPEND
                                              (CDDAR PAT)
                                              (LIST
                                                (CONS
                                                  (QUOTE *GLITCH)
                                                  (CONS
                                                    WMLST
                                                    (MAKE!PAT
                                                      (MAKESUBPAT
                                                        (CDR PAT]
                                            (QUOTE (TRUE)))
                                          (BLKAPPLY*
                                            (CAR FN)
                                            ('LDIFF VAR (CAR WMLST))
                                            (CDR FN]
                          (PATERR "Invalid use of ! in pattern"
                                  (CADAR PAT]
                [$=(RETURN
                    (COND
                      [(NILPAT (CDR PAT))
                        ('AND (OR (NOT CHECKINGLENGTH)
                                  ('EQLENGTH VAR (CDAR PAT)))
                              (BLKAPPLY* (CAR FN)
                                         VAR
                                         (CDR FN]
                      [(AND (EQ (CAR FN)
                                (QUOTE TRUE))
                            (COND
                              ([NULLPAT? (SETQ TAIL
                                           (SKIP$I (CDR PAT]
                                [SETQ TEM2
                                  (OR (NOT CHECKINGLENGTH)
                                      ('NOTLESSPLENGTH
                                        VAR
                                        ('PLUS (CDAR PAT)
                                               SKIPEDLEN]
                                (COND
                                  (INASOME (DOWATCH (SETQ INASOME TEM2))
                                           T)
                                  (T TEM2)))
                              ((NULL TAIL)
                                ('EQLENGTH VAR ('PLUS (CDAR PAT)
                                                      SKIPEDLEN]
                      [(ZEROP (CDAR PAT))
                        ('AND (BLKAPPLY* (CAR FN)
                                         ('LDIFF VAR VAR)
                                         (CDR FN))
                              ('MATCHWM VAR (CDR PAT)
                                        (QUOTE (TRUE]
                      (T [SETQ TEM1 (SUBSTVAR ('NTH VAR (CDAR PAT]
                         ('AND (OR (NOT CHECKINGLENGTH)
                                   (NOT (CANMATCHNILLIST (CDR PAT)))
                                   TEM1)
                               (BLKAPPLY* (CAR FN)
                                          ('LDIFF VAR ('CDR TEM1))
                                          (CDR FN))
                               ('MATCHWM ('CDR TEM1)
                                         (CDR PAT)
                                         (QUOTE (TRUE]
                [@(COND
                    [[AND (CDR PAT)
                          (NOT (ELT? (CDDAR PAT]
                      (RETURN
                        (PROG (INASOME)
                              ('MATCHWM
                                VAR
                                [LIST
                                  (CDDAR PAT)
                                  (CONS
                                    (QUOTE @)
                                    (CONS ('APPLY* (CADAR PAT)
                                                   ('LDIFF
                                                     VAR
                                                     (QUOTE @)))
                                          (MAKE!PAT
                                            (MAKESUBPAT (CDR PAT]
                                FN]
                    ((AND NIL (NLISTP (CADAR PAT))
                          (GETP (CADAR PAT)
                                (QUOTE NARGS))
                          (ELT? (CDDAR PAT)))
                      ('AND ('APPLY* (CADAR PAT)
                                     ('CAR VAR))
                            ('MATCHWM VAR (CONS (CDDAR PAT)
                                                (CDR PAT))
                                      FN]
                NIL))
            (T (RETURN ('MATCHWM VAR (CONS (CDDAR PAT)
                                           (CDR PAT))
                                 (CONS (FUNCTION 'MATCHWMFUNARG)
                                       (CONS (CAR PAT)
                                             FN])

('MATCHWMFUNARG
  [LAMBDA (X ARGS)
    ('AND (SELECTQ (CAAR ARGS)
                   [<-(OR (CHECKSETQ X ARGS)
                          ('SETQ (CADAR ARGS)
                                 X
                                 (CANMATCHNIL (CDDAR ARGS]
                   [←(OR (CHECKSETQ X ARGS)
                         (POSTPONEDSETQ (CADAR ARGS)
                                        X
                                        (CANMATCHNIL (CDDAR ARGS]
                   (-> ('REPLACE X (CADAR ARGS)))
                   (→ (POSTPONEDREPLACE X (CADAR ARGS)))
                   (@('APPLY* (CADAR ARGS)
                              X))
                   (*GLITCH (FRPLACA (CADAR ARGS)
                                     X)
                            (DOWATCH X)
                            T)
                   (PATHELP "MATCH FUNARG MISMATCH" ARGS))
          (SELECTQ (CADR ARGS)
                   (TRUE T)
                   ('MATCHWMFUNARG ('MATCHWMFUNARG X (CDDR ARGS)))
                   (BLKAPPLY* (CADR ARGS)
                              X
                              (CDDR ARGS])

(CHECKSETQ
  [LAMBDA (X ARGS)
    (COND
      ((FMEMB (CADAR ARGS)
              #LIST)
        (MAKESUBST3 (CADAR ARGS)
                    X)
        T)
      ((EQ (CADAR ARGS)
           (QUOTE *))
        (DOWATCH X)
        (SETQ MUSTRETURN X)
        T])

('MATCHELT1
  [LAMBDA (VAR PAT FN)
    ('AND [OR (NOT CHECKINGLENGTH)
              (COND
                ((CDR PAT)
                  (COND
                    ((AND (CANMATCHNIL (CAR PAT))
                          (CANMATCHNILLIST (CDR PAT)))
                      VAR)
                    (T T)))
                ((CANMATCHNIL (CAR PAT))
                  ('EQLENGTH VAR 1))
                (T ('NULL ('CDR VAR]
          ('MATCHELT ('CAR VAR)
                     (CAR PAT))
          (BLKAPPLY* (CAR FN)
                     ('CAR VAR)
                     (CDR FN))
          (OR (NULL (CDR PAT))
              (COND
                ([AND (EQ INASOME (QUOTE FASTINASOME))
                      (FMEMB (CAAR PAT)
                             (QUOTE (= == ']
                  [SETQ INASOME (PROG (INASOME)
                                      ('MATCHWM ('CDR VAR)
                                                (CDR PAT)
                                                (QUOTE (TRUE]
                  T)
                (T ('MATCHWM ('CDR VAR)
                             (CDR PAT)
                             (QUOTE (TRUE])

('MATCHELT
  [LAMBDA (VAR PATELT)                          (* This function matches
                                                VAR against PATELT when 
                                                PATELT is a pattern 
                                                element)
    (COND
      ((NLISTP PATELT)
        (SELECTQ PATELT
                 (($ -- &)
                   T)
                 ('EQUAL VAR PATELT)))
      (T (SELECTQ (CAR PATELT)
                  (==('EQ VAR (CDR PATELT)))
                  [*ANY*('OR (MAPCAR (CDR PATELT)
                                     (FUNCTION (LAMBDA (X)
                                         ('MATCHELT VAR X]
                  [}('NOT ('MATCHELT VAR (CDR PATELT]
                  ['('EQUAL VAR (KWOTE (CDR PATELT]
                  (=('EQUAL VAR (CDR PATELT)))
                  (SUBPAT ('MATCHSUBPAT VAR (CDR PATELT)))
                  ($=(COND
                      [CHECKINGLENGTH (COND
                                        (CHECKLENGTH
                                          ('EQLENGTH VAR (CDR PATELT)))
                                        (T ('NOTLESSPLENGTH
                                             VAR
                                             (CDR PATELT]
                      (T T)))
                  (PATHELP "MATCHELT invalid pattern"])
)
(DEFINEQ

(PATPARSE
  [LAMBDA (PAT)
    (OR (LISTP PAT)
        (PATHELP "bad input" PAT))
    (PROG (DEFAULTLST)
          (PATPARSE1 PAT])

(PATPARSE1
  [LAMBDA (PAT PREFIX)                          (* DECLARATIONS: 
                                                UNDOABLE)
    (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))


          [COND
            [(LISTP (CAR PAT))
              (SELECTQ
                (CAAR PAT)
                ((*ANY* *EVERY*)
                  [SETQ CARPAT (CONS (CAAR PAT)
                                     (PROG ((TOPPAT (CAR PAT)))
                                           (PATPARSE1 (CDAR PAT]
                  (OR (EVERY CARPAT (QUOTE SIMPLELT?))
                      (PATERR "*ANY*/*EVERY* construct too compicated" 
                              PAT))
                  (SETQ CDRPAT (CDR 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 (CADAR PAT)))
                           (/RPLNODE PAT (QUOTE ')
                                     (CONS (CADAR PAT)
                                           (CDR PAT]
                         (T (/RPLACA PAT (PACK (LIST (QUOTE ')
                                                     (CADAR PAT]
                       (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 (CAR PAT)))
                                 (PATPARSE1 (CAR PAT]
                       (SETQ CDRPAT (CDR PAT]
            ((NOT (LITATOM (CAR PAT)))          (* Strings and numbers 
                                                parse to themselves)
              (OR (STRINGP (CAR PAT))
                  (NUMBERP (CAR PAT))
                  (PATERR (QUOTE BADELT)
                          (CAR PAT)))
              (SETQ CARPAT (CAR PAT))
              (SETQ CDRPAT (CDR PAT)))
            ((SETQ TEM (FASSOC (CAR PAT)
                               PATTERNITEMS))

          (* If this is a pattern item;
          PATTERNITEMS is an association list;
          with an entry being (iteminpattern parsing 
          smashpatwith))


              (SETQ CARPAT (OR (CADR TEM)
                               (CAR TEM)))
              (SETQ CDRPAT (CDR PAT)))
            ((SETQ TEM (FASSOC (CAR PAT)
                               PATTERNPREFIXES))

          (* PATTERNPREFIXES is an association list of 
          (opr type form); opr is the 'OPERATOR' 
          (e.g. =); type is either PAT, T, or expr;
          PAT means the next thing is a pattern 
          (as in !) and expr means the next thing is a lisp 
          expression (e.g. =))


              (SETQ TEM3 T)
              (SETQ TEM2 (SELECTQ (CADR TEM)
                                  (EXPR (PATGETEXPR (CDR PAT)))
                                  [PAT (CAR (SETQ TEM3
                                              (PATPARSE1 (CDR PAT]
                                  (CADR PAT)))
              [SETQ CARPAT
                (COND
                  ((LISTP (CADDR TEM))
                    (SUBST TEM2 (QUOTE HERE)
                           (CADDR TEM)))
                  (T (SELECTQ (CADDR TEM)
                              (NEGATEPAT (NEGATEPAT TEM2 PAT))
                              (MAKE!PAT (MAKE!PAT TEM2 TEM3 PAT PREFIX))
                              (BLKAPPLY* (CADDR TEM)
                                         TEM2 TEM3 PAT PREFIX]
              [COND
                ((NEQ TEM3 T)
                  (RETURN (CONS CARPAT (CDR TEM3]
              (SETQ CDRPAT (CDDR PAT)))
            ((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)
               (SETQ CARPAT (CAR PAT))
               (SETQ CDRPAT (CDR 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 ←)


      REINFIX
          (COND
            ((SETQ TEM (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)


                          (TEST# CARPAT)
                          (SETQ TEM3 (PATPARSE1 (CDR CDRPAT)
                                                CDRPAT))
                          (RETURN (CONS (CONS (CADR TEM)
                                              (CONS CARPAT
                                                    (CAR TEM3)))
                                        (CDR TEM3]
                (T (SETQ CARPAT (CONS (CADDR TEM)
                                      (CONS (PATGETEXPR (CDR CDRPAT))
                                            CARPAT)))
                   (SETQ CDRPAT (CDDR CDRPAT]
              (GO REINFIX))
            (NOTFOUND (COND
                        (PREFIX (PATERR (QUOTE AMBIG)
                                        PAT)))
                      (SETQ PAT (PARSEDEFAULT PAT NIL PREFIX))
                      (SETQ NOTFOUND)
                      (GO RETRY))
            ((EQ (CAR CDRPAT)
                 (QUOTE @))
              (SETQ CARPAT (CONS (QUOTE @)
                                 (CONS (PATGETFNNAME (CDR CDRPAT))
                                       CARPAT)))
              (SETQ CDRPAT (CDDR CDRPAT))
              (GO REINFIX))
            ((SETQ TEM (PATUNPACKINFIX CDRPAT))
              (SETQ CDRPAT TEM)
              (GO REINFIX)))
          (RETURN (CONS CARPAT (PATPARSE1 CDRPAT])

(PARSEDEFAULT
  [LAMBDA (PAT LOCALVARDEFAULT PREFIX)

          (* 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 (PACK (CDR (DUNPACK (CAR PAT)
                                                   SKORLST3]
                      (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)))
      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])

(PATUNPACK
  [LAMBDA (PAT)

          (* 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 (DUNPACK 
          (CAR PAT) SKORLST2)) 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))))) (AND RESULTS 
          (NCONC1 RESULTS (PACK CHARS)) 
          (RETURN RESULTS)))))


    (PATPARSEAT PAT PATCHARS])

(PATUNPACKINFIX
  [LAMBDA (L)
    (PATPARSEAT L PATTERNINFIXES])

(PATGETFNNAME
  [LAMBDA (L)
    (OR (LISTP (CAR L))
        (FGETD (CAR L))
        (FIXSPELL (CAR L)
                  70 SPELLINGS2 T L (FUNCTION GETD)
                  T)
        (FIXSPELL (CAR L)
                  70 USERWORDS T L (FUNCTION GETD)
                  T))
    (CAR L])

(PATGETEXPR
  [LAMBDA (L)
    (PATUNPACK L)

          (* THIS DOESN'T WORK, BUT I'LL KEEP THE IDEA HERE IN 
          THIS COMMENT (PROG ((VARS (APPEND #LIST VARS))) 
          (DWIMIFY1B L TOPPAT L T T FAULTFN) 
          (while (AND (NOT (PARSEABLE 
          (CDR L))) (DWIMIFY1B (CDR L) TOPPAT L T T FAULTFN)) 
          do NIL) (RETURN (CAR L))) -
          WHERE PARSEABLE IS DEFINED AS 
          (LAMBDA (PATTERN) (OR (NLISTP PATTERN) 
          (NOT (LITATOM (CAR PATTERN))) 
          (NULL (CAR PATTERN)) (EQ (CAR PATTERN) T) 
          (FASSOC (CAR PATTERN) PATTERNITEMS) 
          (FASSOC (CAR PATTERN) PATTERNINFIXES) 
          (FASSOC (CAR PATTERN) PATTERNPREFIXES) 
          (AND (PATUNPACK PATTERN) (PARSEABLE PATTERN)))))


    (COND
      ((LISTP (CAR L))
        (DWIMIFY1B (CAR L)
                   (CAR L)
                   NIL NIL NIL FAULTFN)))
    (CAR L])

(PATPARSEAT
  [LAMBDA (PAT CHRS)

          (* 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 (STRPOSL PATTERNCHARRAY (CAR PAT))
              (RETURN))
          (SETQ LST (DUNPACK (CAR PAT)
                             SKORLST3))
      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)
    (OR (NLISTP PE)
        (FMEMB (CAR PE)
               (QUOTE (= == ' SUBPAT)))
        (PATERR (QUOTE BADNOT)
                REALPAT))
    (CONS (QUOTE })
          PE])

(PACKLDIFF
  [LAMBDA (LST1 LST2)
    (PROG (TEM1 TEM2)
          (FRPLACD (OR (SETQ TEM1 (NLEFT LST1 1 LST2))
                       (HELP))
                   NIL)
          (PROG1 (PACK LST1)
                 (FRPLACD TEM1 TEM2])
)
(DEFINEQ

(SKIP$I
  [LAMBDA (PAT)

          (* 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)


    (SOME PAT (FUNCTION (LAMBDA (ELT)
              (COND
                ((EQ ELT (QUOTE &))
                  (SETQ SKIPEDLEN ('PLUS 1 SKIPEDLEN))
                  NIL)
                ((EQ (CAR ELT)
                     (QUOTE $=))
                  (SETQ SKIPEDLEN ('PLUS SKIPEDLEN (CDR ELT)))
                  NIL)
                (T])

(SKIP$ANY
  [LAMBDA (PAT)

          (* 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)


    (SOME PAT (FUNCTION (LAMBDA (ELT TEM)
              (COND
                ((NULL (SETQ TEM (PATLEN ELT)))
                  T)
                ((ZEROP TEM)
                  (SETQ ZLENFLG T)
                  NIL)
                (T (SETQ SKIPEDLEN ('PLUS SKIPEDLEN TEM))
                   NIL])

(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
                                         ('PLUS 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))
                  ('(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 })            (* 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)
    (COND
      ((NLISTP PATELT)
        ($? PATELT))
      (T (SELECTQ (CAR PATELT)
                  (! NIL)
                  ((<- → ← -> *GLITCH)
                    (ARB? (CDDR PATELT)))
                  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 (CANMATCHNILLIST (CDR PATELT)))
                 ($< T)
                 ($=(OR (NOT (NUMBERP (CDR PATELT)))
                        (ILESSP (CDR PATELT)
                                1)))
                 ($> NIL)
                 ((← -> → <- *GLITCH)
                   (CANMATCHNIL (CDDR PATELT)))
                 (! (CANMATCHNIL (CDR PATELT)))
                 ('(NULL (CDR PATELT)))
                 [(= ==)
                   (NOT (NEVERNIL (CDR PATELT]
                 (*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)))
                  (($= = == ' $< $> })          (* All of these cannot 
                                                be pointing at a 
                                                REPLACE)
                    NIL)
                  (PATHELP "Invalid pattern REPLACEIN" PATELT])

(REPLACED
  [LAMBDA (PAT)
    (for X in PAT do (COND
                       ((ELT? X)
                         (RETURN))
                       ((REPLACEIN X)
                         (RETURN T])
)
(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])

(TEST#
  [LAMBDA (VAR)                                 (* Check if VAR is a #n 
                                                type variable)
    (COND
      ((FMEMB VAR #LIST))
      ((STRPOS "#" VAR 1 NIL 1)
        (SETQ #LIST (CONS VAR #LIST])

(NEVERNIL
  [LAMBDA (X)
    (COND
      [(LITATOM X)
        (OR (EQ X T)
            (AND X (NOT (COND
                          (PATVARSNILLOOKED PATVARSNIL)
                          (T (SETQ PATVARSNIL (VALUELOOKUP
                                 (QUOTE PATVARSMIGHTBENIL]
      (T (OR (NLISTP X)
             (FMEMB (GETP (CAR X)
                          (QUOTE CLISPCLASS))
                    (QUOTE (+ * ↑ RPLACA RPLACD / - +-)))
             (FMEMB (CAR X)
                    NEVERNILFUNCTIONS])

(FULLEXPANSION
  [LAMBDA (X)
    (PROG (TEM)
          (COND
            ([OR (EQ (CAR X)
                     (QUOTE CAR))
                 (EQ (CAR X)
                     (QUOTE CDR))
                 (NULL (SETQ TEM (FASSOC (CAR X)
                                         CRLIST]
              X)
            (T (LIST (CADDDR TEM)
                     (LIST (CAR (CDDDDR TEM))
                           (CADR X])

(GENSYML
  [LAMBDA NIL
    (OR (CAR (SETQ GENSYMVARLIST (CDR GENSYMVARLIST)))
        (GENSYM])

(MAKESUBST
  [LAMBDA (OLD NEW NOVARFLG)
    (SETQ SUBLIST (CONS [CONS OLD (CONS NEW (NOT (NULL NOVARFLG]
                        SUBLIST))
     OLD])

(MAKESUBST3
  [LAMBDA (VAR VAL)
    (DOWATCH VAR)
    (DOWATCH VAL)
    (MAKESUBST0 VAR VAL])

(MAKESUBST0
  [LAMBDA (OLD NEW)
    (MAKESUBST OLD NEW NIL])

(MAKESUBST1
  [LAMBDA (OLD NEW)
    (MAKESUBST OLD NEW (EASYTORECOMPUTE NEW])

(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 PARENTEXPRESSION)
    (PROG (TEM1 TEM2)
          (COND
            ((NLISTP EXPRESSION)
              NIL)
            ([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 (BOUNDVAR))
                  (FRPLACA (CDDR TEM1)
                           ('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)
                  (FRPLACD (CDR TEM1)
                           EXPRESSION)))
              (FRPLACA EXPRESSION (OR (DOSUBST1 (CADR TEM1))
                                      (CADR TEM1)))
                                                (* Might need to 
                                                substitutions within 
                                                substituted EXPRESSION)
              (FRPLACD EXPRESSION (OR (DOSUBST1 (CDR EXPRESSION))
                                      (CDR EXPRESSION)))
              EXPRESSION)
            (T
              (SELECTQ
                (CAR EXPRESSION)
                [(PROG 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 (NCONC [MAPCAR
                                           (CADR EXPRESSION)
                                           (FUNCTION (LAMBDA (X)
                                               (COND
                                                 ((LISTP X)
                                                   (CAR X))
                                                 (T X]
                                         SUBLIST))
                         TEM)
                        (COND
                          ((SETQ TEM (DOSUBST1 (CDDR EXPRESSION)))
                            (FRPLACD (CDR EXPRESSION)
                                     TEM)
                            EXPRESSION]
                (QUOTE NIL)
                (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)))
                      (AND (OR A D)
                           (CONS (OR A (CAR EXPRESSION))
                                 (OR D (CDR EXPRESSION])

(FORMEXPAND
  [LAMBDA (LIST AT)

          (* Searches for (AT --) AT the top level of list and 
          does a (1) up (bo 1) on them)


    [for X on LIST do (AND (EQ (CAAR X)
                               AT)
                           (FRPLACD X (NCONC (CDDAR X)
                                             (CDR X)))
                           (FRPLACA X (CADAR X]
    LIST])

(POSTPONEDREPLACE
  [LAMBDA (VAR VALUE)
    (DOWATCH VALUE)
    (DOWATCH VAR)
    (SETQ POSTPONEDRPLACS (CONS ('REPLACE VAR VALUE)
                                POSTPONEDRPLACS))
    T])

(POSTPONEDSETQ
  [LAMBDA (VARTOSET VALUE CANBENILFLG)
    (DOWATCH VARTOSET)
    (DOWATCH VALUE)
    (SETQ POSTPONEDEFFECTS (CONS ('SETQ VARTOSET VALUE)
                                 POSTPONEDEFFECTS))
    (SETQ LASTEFFECTCANBENIL CANBENILFLG)
    T])

(SUBSTVAR
  [LAMBDA (EXPR)
    (PROG (TEM)
          (MAKESUBST0 (SETQ TEM (GENSYML))
                      EXPR)
          (RETURN TEM])

(BOUNDVAR
  [LAMBDA NIL
    (BINDVAR (GENSYML])

(BINDVAR
  [LAMBDA (VAR)
    (SETQ BINDINGS (CONS VAR BINDINGS))
    VAR])

(SELFQUOTEABLE
  [LAMBDA (EXPRESSION)
    (OR (NUMBERP EXPRESSION)
        (STRINGP EXPRESSION)
        (NULL EXPRESSION)
        (EQ EXPRESSION T])

(FINDIN0
  [LAMBDA (VAR EXPR)
    (OR (FINDIN1 VAR EXPR)
        (SOME SUBLIST (FUNCTION (LAMBDA (X)
                  (AND (FINDIN1 (CAR X)
                                EXPR)
                       (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 (EXPR)
    (AND WATCHPOSTPONELST (MAP WATCHPOSTPONELST
                               (FUNCTION (LAMBDA (X)
                                   (AND (NEQ (CAR X)
                                             (QUOTE FOUND))
                                        (FINDIN0 (CAR X)
                                                 EXPR)
                                        (FRPLACA X (QUOTE FOUND])

(UNCROP
  [LAMBDA (EXPR)
    (COND
      ((NLISTP EXPR)
        EXPR)
      ((GETP (CAR EXPR)
             (QUOTE CROPS))
        (UNCROP (CADR EXPR)))
      (T (SELECTQ (CAR EXPR)
                  ((CAR CDR NTH NLEFT LAST FLAST FNTH SOME)
                    (UNCROP (CADR EXPR)))
                  ((MEMB FMEMB MEMBER)
                    (UNCROP (CADDR EXPR)))
                  EXPR])

(PATNARGS
  [LAMBDA (X)
    (OR (GETP X (QUOTE NARGS))
        (NARGS X])

(UNCDR
  [LAMBDA (VAR)
    (AND (EQ (CAR (SETQ VAR (FULLEXPANSION VAR)))
             (QUOTE CDR))
         (CADR VAR])

(CHECKEASYVAR
  [LAMBDA (VAR PAT)
    (PROG (TEM)
          (COND
            ((EASYTORECOMPUTE VAR)
              VAR)
            (T (COND
                 [[AND (REPLACED PAT)
                       (FMEMB (CAR (SETQ TEM (FULLEXPANSION VAR)))
                              (QUOTE (CAR CDR]
                   (LIST (CAR TEM)
                         (SUBSTVAR (CADR TEM]
                 (T (SUBSTVAR VAR])
)
(DEFINEQ

('NLEFT
  [LAMBDA (EXPRESSION N TAIL NOTFASTFLG)
    (COND
      (TAIL (LIST (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 ('LAST EXPRESSION]
      (T (LIST (QUOTE NLEFT)
               EXPRESSION N])

('NOT
  [LAMBDA (X)
    ('NOT1 X (QUOTE NOT])

('NULL
  [LAMBDA (X)
    ('NOT1 X (QUOTE NULL])

('NOT1
  [LAMBDA (X FNNAME)
    (COND
      ((NLISTP X)
        (SELECTQ X
                 (NIL T)
                 (T NIL)
                 (LIST FNNAME X)))
      (T (SELECTQ (CAR X)
                  ((NOT NULL)
                    (CADR X))
                  (EQ (FRPLACA X (QUOTE NEQ)))
                  (NEQ (FRPLACA X (QUOTE EQ)))
                  [(OR AND)
                    (for Y on (CDR X)
                       do (FRPLACA Y ('NOT1 (CAR Y)
                                            FNNAME)))
                    (FRPLACA X (COND
                               ((EQ (CAR X)
                                    (QUOTE AND))
                                 (QUOTE OR))
                               (T (QUOTE OR]
                  (LISTP (FRPLACA X (QUOTE NLISTP)))
                  (NLISTP (FRPLACA X (QUOTE LISTP)))
                  (LIST FNNAME X])

('NOTLESSPLENGTH
  [LAMBDA (X N)
    (COND
      ((ZEROP N)
        T)
      (T ('NTH X N])

('NTH
  [LAMBDA (VAR LEN)
    (COND
      ((OR (NOT (SMALLP LEN))
           (ILESSP LEN 1)
           (IGREATERP LEN MAXCDDDDRS))
        (LIST (COND
                (CHECKINGLENGTH (LOOK (QUOTE NTH)))
                (T (QUOTE FNTH)))
              VAR LEN))
      (T (PROG NIL
           LP  (COND
                 ((EQ LEN 1)
                   VAR)
                 ((EQ LEN 2)
                   (LIST (QUOTE CDR)
                         VAR))
                 ((EQ LEN 3)
                   (LIST (QUOTE CDDR)
                         VAR))
                 ((EQ LEN 4)
                   (LIST (QUOTE CDDDR)
                         VAR))
                 ((EQ LEN 5)
                   (LIST (QUOTE CDDDDR)
                         VAR))
                 (T (WHILE (IGREATERP LEN 5)
                       DO (SETQ VAR (LIST (QUOTE CDDDDR)
                                          VAR))
                          (SETQ LEN (IDIFFERENCE LEN 4)))
                    (GO LP])

('OR
  [LAMBDA (LISTOFEXPRESSIONS)
    (COND
      [(CDR LISTOFEXPRESSIONS)
        (CONS (QUOTE OR)
              (FORMEXPAND LISTOFEXPRESSIONS (QUOTE OR]
      (T (CAR LISTOFEXPRESSIONS])

('PLUS
  [LAMBDA (EXPR1 EXPR2)
    (COND
      ((AND (NUMBERP EXPR1)
            (NUMBERP EXPR2))
        (IPLUS EXPR1 EXPR2))
      (T (PROG ((SUM 0)
                (LST (FORMEXPAND (LIST EXPR1 EXPR2)
                                 (QUOTE IPLUS)))
                VAL)
               [FOR X in LST do (COND
                                  ((NUMBERP X)
                                    (SETQ SUM (IPLUS X SUM)))
                                  (T (SETQ VAL (NCONC1 VAL X]
               (COND
                 ((NULL VAL) SUM)
                 ((IGREATERP SUM 0)
                   (CONS (QUOTE IPLUS)
                         (CONS SUM VAL)))
                 ((NULL (CDR VAL))
                   (CAR VAL))
                 (T (CONS (QUOTE IPLUS)
                          VAL])

('REPLACE
  [LAMBDA (VAR EXPRESSION)
    (SETQ VAR (FULLEXPANSION VAR))
    (COND
      ((EQUAL VAR EXPRESSION)
        T)
      ((EQ (CAR VAR)
           (QUOTE CAR))
        (LOOKLIST (QUOTE RPLACA)
                  (CADR VAR)
                  EXPRESSION))
      ((EQ (CAR VAR)
           (QUOTE CDR))
        (LOOKLIST (QUOTE RPLACD)
                  (CADR VAR)
                  EXPRESSION))
      [(EQ (CAR VAR)
           (QUOTE LDIFF))
        ('REPLACE (CADR VAR)
                  ('NCONC EXPRESSION (CADDR VAR]
      [(COND
          ((EQ (CAR EXPRESSION)
               (QUOTE CONS))
            T)
          ((EQ (CAR EXPRESSION)
               (QUOTE LIST))
            [COND
              ((CDDR EXPRESSION)
                (SETQ EXPRESSION (LIST NIL (CADR EXPRESSION)
                                       (CONS (QUOTE LIST)
                                             (CDDR EXPRESSION]
            T))
        ('PROGN (LIST ('REPLACE (LIST (QUOTE CAR)
                                      VAR)
                                (CADR EXPRESSION))
                      ('REPLACE (LIST (QUOTE CDR)
                                      VAR)
                                (CADDR EXPRESSION]
      (T (LOOKLIST (QUOTE RPLNODE2)
                   VAR EXPRESSION])

('SETQ
  [LAMBDA (VAR EXPRESSION PROGNFLG)
    (SETQ EXPRESSION (LIST (QUOTE SETQ)
                           VAR EXPRESSION))
    (COND
      (PROGNFLG (LIST (QUOTE PROGN)
                      EXPRESSION T))
      (T EXPRESSION])

('AND
  [LAMBDA N
    (PROG ((NARGS N)
           EXPR1 EXPR2)
          (SETQ EXPR2 (ARG N NARGS))
      LP  (SETQ NARGS (SUB1 NARGS))
          (COND
            ((ZEROP NARGS)
              (RETURN EXPR2)))
          (SETQ EXPR1 (ARG N NARGS))
          (SETQ EXPR2 ('AND2 EXPR1 EXPR2))
          (GO LP])

('AND2
  [LAMBDA (EXPR1 EXPR2)                         (* DECLARATIONS: FAST)
    (PROG (TEM)
          (COND
            ((EQ EXPR1 T)
              EXPR2)
            ((EQ EXPR2 T)
              EXPR1)
            ((EQUAL EXPR1 EXPR2)
              EXPR2)
            ((EQUAL EXPR1 (UNCROP EXPR2))
              EXPR2)
            ((EQ (CAR EXPR1)
                 (QUOTE PROGN))
              (SETQ TEM (FLAST EXPR1))
              (FRPLACA TEM ('AND (CAR TEM)
                                 EXPR2))
              EXPR1)
            ((AND (EQ (CAR EXPR2)
                      (QUOTE COND))
                  (NOT (CDDR EXPR2)))
              (FRPLACA (CADR EXPR2)
                       ('AND EXPR1 (CAADR EXPR2)))
              EXPR2)
            ((AND (EQ (CAR EXPR1)
                      (QUOTE COND))
                  (NULL (CDDR EXPR1)))
              (FRPLACA (SETQ TEM (FLAST (CADR EXPR1)))
                       ('AND (CAR TEM)
                             EXPR2))
              EXPR1)
            ((AND (EQ (CAR EXPR2)
                      (QUOTE OR))
                  (EQ (CADDR EXPR2)
                      T))
              (LIST (QUOTE COND)
                    (LIST EXPR1 (CADR EXPR2)
                          T)))
            [(EQ (CAR EXPR2)
                 (QUOTE PROGN))
              (LIST (QUOTE COND)
                    (CONS EXPR1 (CDR EXPR2]
            [(EQ (CAR EXPR2)
                 (QUOTE AND))
              (COND
                ((EQ (CAR EXPR1)
                     (QUOTE AND))
                  (NCONC EXPR1 (CDR EXPR2)))
                (T (FRPLACD EXPR2 (CONS EXPR1 (CDR EXPR2]
            ((EQ (CAR EXPR1)
                 (QUOTE AND))
              (NCONC1 EXPR1 EXPR2))
            [(AND [OR (AND (EQ (CAR EXPR1)
                               (QUOTE SETQ))
                           (SETQ TEM EXPR1))
                      (AND (EQ (CAR EXPR1)
                               (QUOTE OR))
                           (EQ (CAADR EXPR1)
                               (QUOTE SETQ))
                           (EQ (CADDR EXPR1)
                               T)
                           (SETQ TEM (CADR EXPR1]
                  (COND
                    ((EQ EXPR2 (CADR TEM))
                      TEM)
                    ((AND (EQ (CAR EXPR2)
                              (QUOTE AND))
                          (EQ (CADR TEM)
                              (CADR EXPR2)))
                      (FRPLACA (CDR EXPR2)
                               TEM)
                      EXPR2]
            ([AND (EQ (CAR EXPR1)
                      (QUOTE PROG))
                  (FMEMB (CAR (SETQ TEM (NLEFT EXPR1 2)))
                         (QUOTE ($$LP $$SOMELP $$RPTLP]
              [COND
                ((EQ [CAR (SETQ TEM
                            (CAR (LAST (CAR (LAST (CADR TEM]
                     (QUOTE RETURN))
                  (RPLACA (CDR TEM)
                          ('AND (CADR TEM)
                                EXPR2)))
                (T (PATHELP (QUOTE AND]
              EXPR1)
            (T (LIST (QUOTE AND)
                     EXPR1 EXPR2])

('CAR
  [LAMBDA (X)
    (PROG (TEM)
          (COND
            ([NULL (SETQ TEM (CADR (FASSOC (CAR X)
                                           CRLIST]
              (LIST (QUOTE CAR)
                    X))
            (T (LIST TEM (CADR X])

('CDR
  [LAMBDA (X)
    (PROG (TEM)
          (COND
            ([NULL (SETQ TEM (CADDR (FASSOC (CAR X)
                                            CRLIST]
              (LIST (QUOTE CDR)
                    X))
            (T (LIST TEM (CADR X])

('EQ
  [LAMBDA (VAR EXPRESSION)
    (COND
      ((NULL EXPRESSION)
        ('NULL VAR))
      ((ZEROP EXPRESSION)
        (LIST (QUOTE ZEROP)
              VAR))
      (T (LIST (QUOTE EQ)
               VAR EXPRESSION])

('EQLENGTH
  [LAMBDA (VAR LEN)

          (* THIS SHOULD REALLY TAKE 
          (EQLENGTH (CDDDR X) 10) AND TRANSLATE IT TO 
          (EQLENGTH X 13))


    (SELECTQ (CAR (LISTP VAR))
             (CDR ('EQLENGTH (CADR VAR)
                             ('PLUS LEN 1)))
             (CDDR ('EQLENGTH (CADR VAR)
                              ('PLUS LEN 2)))
             (CDDDR ('EQLENGTH (CADR VAR)
                               ('PLUS LEN 3)))
             (CDDDDR ('EQLENGTH (CADR VAR)
                                ('PLUS LEN 4)))
             (COND
               ((ZEROP LEN)
                 ('NULL VAR))
               (T (LIST (QUOTE EQLENGTH)
                        VAR LEN])

('EQUAL
  [LAMBDA (VAR EXPRESSION)
    [COND
      ((AND (EQ (CAR EXPRESSION)
                (QUOTE QUOTE))
            (SELFQUOTEABLE (CADR EXPRESSION)))
        (SETQ EXPRESSION (CADR EXPRESSION]
    (COND
      ((NULL EXPRESSION)
        ('NULL VAR))
      ((EQ EXPRESSION T)
        ('EQ VAR EXPRESSION))
      (T (LIST (COND
                 ([OR (SMALLP EXPRESSION)
                      (AND (EQ (CAR EXPRESSION)
                               (QUOTE QUOTE))
                           (LITATOM (CADR EXPRESSION]
                   (QUOTE EQ))
                 ((NUMBERP EXPRESSION)
                   (QUOTE EQP))
                 ((STRINGP EXPRESSION)
                   (QUOTE STREQUAL))
                 (T (QUOTE EQUAL)))
               VAR EXPRESSION])

('LAST
  [LAMBDA (X)
    (LIST (LOOK (QUOTE LAST)
                X)
          X])

('F/L
  [LAMBDA (ARGS EXPR)
    (DSUBST (CAR ARGS)
            ('CAR (CADR ARGS))
            EXPR)
    (LIST (QUOTE FUNCTION)
          (COND
            ([AND (EQ (CADR EXPR)
                      (CAR ARGS))
                  (OR (AND (EQLENGTH EXPR 2)
                           (EQ (PATNARGS (CAR EXPR))
                               1))
                      (AND (EQ (PATNARGS (CAR EXPR))
                               1)
                           (EQLENGTH EXPR 3)
                           (EQ (CADDR EXPR)
                               (CADR ARGS]
              (CAR EXPR))
            (T (LIST (QUOTE LAMBDA)
                     ARGS EXPR])

('APPLY*
  [LAMBDA (FNNAME VAR)
    (COND
      ((OR (NLISTP FNNAME)
           (EQ (CAR FNNAME)
               (QUOTE LAMBDA)))
        (LIST FNNAME VAR))
      (T (SUBST VAR (QUOTE @)
                FNNAME])

('HEADPLOOP
  [LAMBDA (VAR HEADLIST TAILVAR CANNILFLG AFTEREXP)

          (* (FOR {TAILVAR⎇ ON {VAR⎇ BIND {TEMVAR⎇←{HEADLIST⎇ 
          WHILE {TAILVAR⎇:1 EQUALS {TEMVAR⎇:1 DO 
          (IF NIL={TEMVAR⎇←{TEMVAR⎇::1 THEN 
          (RETURN {AFTER⎇))))


    (PROG (TEMVAR)
          (SUBPAIR (QUOTE (TEMVAR AFTER VAR TAILVAR HEADLIST))
                   (LIST (SETQ TEMVAR (BOUNDVAR))
                         (COND
                           [(EQ AFTEREXP T)
                             ('OR (LIST ('NULL TEMVAR)
                                        ('EQ TEMVAR TAILVAR]
                           ((NOT CANNILFLG)
                             ('AND ('NULL TEMVAR)
                                   AFTEREXP))
                           (T ('AND ('OR (LIST ('NULL TEMVAR)
                                               ('EQ TEMVAR TAILVAR)))
                                    AFTEREXP)))
                         VAR TAILVAR HEADLIST)
                   (QUOTE (PROG NIL
                                (SETQ TAILVAR VAR)
                                (SETQ TEMVAR HEADLIST)
                            $$LP(COND
                                  ((LISTP TEMVAR)
                                    (COND
                                      ((AND (LISTP TAILVAR)
                                            (EQUAL (CAR TAILVAR)
                                                   (CAR TEMVAR)))
                                        (SETQ TAILVAR (CDR TAILVAR))
                                        (SETQ TEMVAR (CDR TEMVAR))
                                        (GO $$LP)))
                                    (RETURN))
                                  (T (RETURN AFTER])

('LDIFF
  [LAMBDA (X Y)
    (LIST (QUOTE LDIFF)
          X Y])

('PROG
  [LAMBDA (VARS STATEMENTS)
    (COND
      ((AND (NULL (CDR STATEMENTS))
            (EQ (CAAR STATEMENTS)
                (QUOTE PROG)))
        (RPLACA (CDAR STATEMENTS)
                (APPEND (CADAR STATEMENTS)
                        VARS))
        (CAR STATEMENTS))
      (T (CONS (QUOTE PROG)
               (CONS VARS STATEMENTS])

('NCONC
  [LAMBDA (VAR1 VAR2)
    (COND
      ((NULL VAR1)
        VAR2)
      (T (LOOKLIST (QUOTE NCONC)
                   VAR1 VAR2])

('FOR
  [LAMBDA ({OLD⎇ I.V. {ON⎇VAR {UNTIL⎇EXPR {FINALLY⎇EXPR NOSOMEFLG)
    (PROG (TEM1)
          (AND (EQ {UNTIL⎇EXPR T)
               (PATHELP " a SOME with null terminator"
                        (LIST {OLD⎇ I.V. {ON⎇VAR {FINALLY⎇EXPR)))
          (AND NOSOMEFLG (GO DOPROG))
          [SETQ TEM1 (OR (SELECTQ (CAR {UNTIL⎇EXPR)
                                  (EQ (AND (EQUAL (CADR {UNTIL⎇EXPR)
                                                  ('CAR I.V.))
                                           (LOOKLIST (QUOTE MEMB)
                                                     (CADDR {UNTIL⎇EXPR)
                                                     {ON⎇VAR)))
                                  (EQUAL (AND (EQUAL (CADR {UNTIL⎇EXPR)
                                                     ('CAR I.V.))
                                              (LIST (QUOTE MEMBER)
                                                    (CADDR {UNTIL⎇EXPR)
                                                    {ON⎇VAR)))
                                  NIL)
                         (LIST (QUOTE SOME)
                               {ON⎇VAR
                               ('F/L (LIST (GENSYML)
                                           I.V.)
                                     {UNTIL⎇EXPR]
          (RETURN (COND
                    [(OR {OLD⎇ (NEQ {FINALLY⎇EXPR T))
                      (MAKESUBST0 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 (COND
                                ((NEQ {FINALLY⎇EXPR T)
                                  {FINALLY⎇EXPR)
                                (T I.V.]
                    (T TEM1)))
      DOPROG
          (RETURN
            ('PROG
              (AND (NOT {OLD⎇)
                   (LIST (LIST I.V. {ON⎇VAR)))
              (NCONC
                (AND {OLD⎇ (LIST ('SETQ (BINDVAR I.V.)
                                        {ON⎇VAR)))
                (LIST (QUOTE $$SOMELP)
                      (LIST (QUOTE COND)
                            (LIST ('NOT {UNTIL⎇EXPR)
                                  [LIST (QUOTE COND)
                                        (LIST ('LISTP I.V.)
                                              ('SETQ I.V. ('CDR I.V.))
                                              (QUOTE (GO $$SOMELP]
                                  (QUOTE (RETURN)))
                            (LIST T (LIST (QUOTE RETURN)
                                          {FINALLY⎇EXPR])

('PROGN
  [LAMBDA (EXPRLST)
    (PROG (X)
          (OR EXPRLST (RETURN T))
          (SETQ EXPRLST (FORMEXPAND EXPRLST (QUOTE PROGN)))
          (while (AND (CDR EXPRLST)
                      (NLISTP (CAR EXPRLST)))
             do (SETQ EXPRLST (CDR EXPRLST)))
          (SETQ X EXPRLST)
      LP  (COND
            ((CDDR X)
              [COND
                ((NLISTP (CAR X))
                  (FRPLACA X (CADR X))
                  (FRPLACD X (CDDR X)))
                (T (SETQ X (CDR X]
              (GO LP)))
          (RETURN (COND
                    ((CDR EXPRLST)
                      (CONS (QUOTE PROGN)
                            EXPRLST))
                    (T (CAR EXPRLST])

('LISTP
  [LAMBDA (X)
    (LIST (QUOTE LISTP)
          X])
)
(DEFINEQ

(PATERR
  [LAMBDA (MSG AT)
    (CLISPERROR
      (LIST (SELECTQ MSG
                     (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"))
            AT MATCHEXPRESSION)
      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)
    (COND
      (LOCALDECLARATION (CLISPLOOKUP0 VAR (CADR MATCHEXPRESSION)
                                      NIL LOCALDECLARATION NIL
                                      (QUOTE VALUE)))
      (T (CAR VAR])

(LOOK
  [LAMBDA (FN ARG ARG')
    (PROG (CLASS CLASSDEF (LISPFN (OR (GETP FN (QUOTE LISPFN))
                                      FN)))
          (COND
            ([AND LOCALDECLARATION (SETQ CLASSDEF (GETP FN
                                                        (QUOTE 
                                                      CLISPCLASSDEF]
              (CLISPLOOKUP0 FN ARG ARG' LOCALDECLARATION LISPFN
                            (GETP FN (QUOTE CLISPCLASS))
                            CLASSDEF))
            (T LISPFN])

(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])

(TRUE
  [LAMBDA NIL T])
)
(DECLARE
  (BLOCK: MATCHBLOCK MAKEMATCH 'MATCHTOP 'MATCHSUBPAT 'MATCHWM 
          'MATCHWMFUNARG CHECKSETQ 'MATCHELT1 'MATCHELT PATPARSE 
          PATPARSE1 PARSEDEFAULT PATUNPACK PATUNPACKINFIX PATGETFNNAME 
          PATGETEXPR PATPARSEAT MAKE!PAT MAKESUBPAT NEGATEPAT PACKLDIFF 
          SKIP$I SKIP$ANY PATLEN $? ELT? SIMPLELT? ARB? NULLPAT? NILPAT 
          CANMATCHNIL CANMATCHNILLIST REPLACEIN REPLACED 
          EASYTORECOMPUTE TEST# NEVERNIL FULLEXPANSION GENSYML 
          MAKESUBST MAKESUBST0 MAKESUBST3 MAKESUBST1 DOSUBST DOSUBST1 
          FORMEXPAND POSTPONEDREPLACE POSTPONEDSETQ SUBSTVAR BOUNDVAR 
          BINDVAR SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH UNCROP PATNARGS 
          UNCDR CHECKEASYVAR 'NLEFT 'NOT 'NULL 'NOT1 'NOTLESSPLENGTH 
          'NTH 'OR 'PLUS 'REPLACE 'SETQ 'AND 'AND2 'CAR 'CDR 'EQ 
          'EQLENGTH 'EQUAL 'LAST 'F/L 'APPLY* 'HEADPLOOP 'LDIFF 'PROG 
          'NCONC 'FOR 'PROGN 'LISTP PATERR PATHELP LOOKLIST LOOK 
          VALUELOOKUP VARCHECK TRUE (ENTRIES MAKEMATCH)
          (GLOBALVARS PATCHARS CRLIST MAXCDDDDRS PATNONNILFUNCTIONS 
                      PATGENSYMVARS PATTERNITEMS PATTERNPREFIXES 
                      PATTERNREPLACEOPRS PATTERNINFIXES PATTERNCHARRAY 
                      NEVERNILFUNCTIONS)
          (LOCALFREEVARS WATCHPOSTPONELST SUBLIST INASOME 
                         CHECKINGLENGTH WMLST LASTEFFECTCANBENIL 
                         POSTPONEDEFFECTS MUSTRETURN BINDINGS 
                         GENSYMVARLIST SKIPEDLEN ZLENFLG 
                         LOCALDECLARATION MATCHEXPRESSION MATCHEFFECTS 
                         CHECKLENGTH #LIST PATVARSNILLOOKED PATVARSNIL 
                         POSTPONEDRPLACS LISTPCHECK DEFAULTLST 
                         VARDEFAULT)
          (SPECVARS EXPR FAULTFN VARS CLISPCHANGE)
          (BLKAPPLYFNS TRUE 'MATCHWMFUNARG))
) (RPAQQ PATCHARS ((($ <)
           T $<)
          (($ >)
           T $>)
          (($ =)
           T $=)
          ((')
           T ')
          ((!)
           T !)
          ((= =)
           T ==)
          ((=)
           T =)
          ((})
           T })
          ((< -)
           NIL <-)
          ((@)
           NIL @)
          ((←)
           NIL ←)
          (($)
           T $)))
  (RPAQQ PATTERNINFIXES (((←)
           T ←)
          ((< -)
           T <-)
          ((@)
           T @)))
  (RPAQQ PATTERNREPLACEOPRS ((← ← →)
          (←← <- ->)
          (<- <- ->)))
  [RPAQQ PATTERNITEMS ((&)
          (--)
          ($$ --)
          (T)
          (NIL)
          (&)
          (--)
          ($)
          ($1 &)
          ($2 ($= . 2))
          ($3 ($= . 3))
          ($4 ($= . 4))
          ($5 ($= . 5))
          ($6 ($= . 6]
  (RPAQQ PATTERNPREFIXES ((== EXPR (== . HERE))
          (= EXPR (= . HERE))
          (' T (' . HERE))
          (! PAT MAKE!PAT)
          (%. PAT MAKE!PAT)
          ($> EXPR ($> . HERE))
          ($< EXPR ($< . HERE))
          ($= EXPR ($= . HERE))
          (} PAT NEGATEPAT)))
  (RPAQQ CRLIST ((CAR CAAR CDAR CAR NIL)
          (CDR CADR CDDR CDR NIL)
          (CDDDDR NIL NIL CDR CDDDR)
          (CADDDR NIL NIL CAR CDDDR)
          (CDDDR CADDDR CDDDDR CDR CDDR)
          (CDADDR NIL NIL CDR CADDR)
          (CAADDR NIL NIL CAR CADDR)
          (CADDR CAADDR CDADDR CAR CDDR)
          (CDDR CADDR CDDDR CDR CDR)
          (CDDADR NIL NIL CDR CDADR)
          (CADADR NIL NIL CAR CDADR)
          (CDADR CADADR CDDADR CDR CADR)
          (CDAADR NIL NIL CDR CAADR)
          (CAAADR NIL NIL CAR CAADR)
          (CAADR CAAADR CDAADR CAR CADR)
          (CADR CAADR CDADR CAR CDR)
          (CDDDAR NIL NIL CDR CDDAR)
          (CADDAR NIL NIL CAR CDDAR)
          (CDDAR CADDAR CDDDAR CDR CDAR)
          (CDADAR NIL NIL CDR CADAR)
          (CAADAR NIL NIL CAR CADAR)
          (CADAR CAADAR CDADAR CAR CDAR)
          (CDAR CADAR CDDAR CDR CAR)
          (CDDAAR NIL NIL CDR CDAAR)
          (CADAAR NIL NIL CAR CDAAR)
          (CDAAR CADAAR CDDAAR CDR CAAR)
          (CDAAAR NIL NIL CDR CAAAR)
          (CAAAAR NIL NIL CAR CAAAR)
          (CAAAR CAAAAR CDAAAR CAR CAAR)
          (CAAR CAAAR CDAAR CAR CAR)))
  (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 PATTERNVARDEFAULT ('))
  (RPAQQ MAXCDDDDRS 5)
  (RPAQ PATTERNCHECKLENGTH T)
  (RPAQ PATTERNLISTPCHECK NIL)
  (RPAQ PATVARSMIGHTBENIL T)
(DEFLIST(QUOTE(
  (NTH NTH)
))(QUOTE CLISPCLASS))

(DEFLIST(QUOTE(
  (NTH (ACCESS NTH NIL FNTH))
))(QUOTE CLISPCLASSDEF))

(DEFLIST(QUOTE(
  (NTH NTH)
))(QUOTE LISPFN))

  (ADDTOVAR DECLWORDS (QUOTE (NTH)))
STOP