(FILECREATED "27-AUG-73  1:00:36" IMATCH)


(DEFINEQ

(MATCHTOP
  [LAMBDA (EXPRESSION PAT)
    (PROG (MUSTRETURN RETVAL TEM SIDES)
          (IF (TEM←(MATCH EXPRESSION PAT))
              THEN (FOR X IN SIDES DO (EVAL X))
                   (IF MUSTRETURN
                       THEN RETVAL
                     ELSE TEM])

(MATCHELT
  [LAMBDA (VAR PATELT)                          (* This function matches
                                                VAR against PATELT when 
                                                PATELT is a pattern 
                                                element)
    (COND
      ((NLISTP PATELT)
        (SELECTQ PATELT
                 (& T)
                 (($ --)                        (* Segments matching 
                                                anything)
                   T)
                 (EQUAL VAR PATELT)))
      (T (SELECTQ (CAR PATELT)
                  (* (MAKERETURN VAR)
                     (MATCHELT VAR (CDR PATELT)))
                  [==(EQ VAR (EVAL (CDR PATELT]
                  ('(EQUAL VAR (CDR PATELT)))
                  [=(EQUAL VAR (EVAL (CDR PATELT]
                  (@ (AND (MATCHELT VAR (CDDR PATELT))
                          (APPLY* (CADR PATELT)
                                  VAR)))
                  (←(AND (MATCHELT VAR (CDDR PATELT))
                         (OR (SETQ (CADR PATELT)
                               VAR)
                             T)))
                  (<-(POSTPONESETQ (CADR PATELT)
                                   VAR)
                    (MATCHELT VAR (CDDR PATELT)))
                  (-> (HELP "REPLACE")
                      (POSTPONEDREPLACE VAR (CADR PATELT))
                      (MATCHELT VAR (CDDR PATELT)))
                  [→ (HELP "REPLACE")
                      (AND (MATCHELT VAR (CDDR PATELT))
                           (REPLACE VAR (CADR PATELT]
                  (SUBPAT (MATCH VAR (CDR PATELT)))
                  ((≠ ≠≠)                    (* FIX UP WITH EDITOR 
                                                INTERNAL CALLS RATHER 
                                                THAN EDIT4E)
                    (EDIT4E PATELT VAR))
                  [}(NOT (MATCHELT VAR (CDR PATELT]
                  (! (MATCHELT VAR (CDR PATELT)))
                  [$PACKED$ (EQLENGTH VAR (EVAL (CDR PATELT]
                  [*ANY*(SOME (CDR PATELT)
                              (F/L (PE)
                                   (MATCHELT VAR PE]
                  [*EVERY*(EVERY (CDR PATELT)
                                 (F/L (PE)
                                      (MATCHELT VAR PE]
                  (HELP "Invalid pattern in MATCHELT" PATELT])

(POSTPONESETQ
  [LAMBDA (VAR VALUE)
    (SETQ SIDES (NCONC1 SIDES (LIST (QUOTE SETQQ)
                                    VAR VALUE)))
    T])

(MATCH
  [LAMBDA (VAR PAT)                             (* Interpretive matcher,
                                                for debugging purposes)
    (COND
      ((NULL PAT)
        (NULL VAR))
      [(ELT? (CAR PAT))
        (AND (MATCHELT (CAR VAR)
                       (CAR PAT))
             (MATCH (CDR VAR)
                    (CDR PAT]
      ((NULL (CDR PAT))
        (MATCHELT VAR (CAR PAT)))
      [($? (CAR PAT))
        (SOME VAR (FUNCTION (LAMBDA (FOO X)
                  (MATCH X (CDR PAT]
      (T
        (SELECTQ
          (CAAR PAT)
          (* (MATCHWM VAR (CONS (CDAR PAT)
                                (CDR PAT))
                      (FUNCTION MAKERETURN)))
          ((*EVERY* *ANY*)                      (* Segment any's go 
                                                here)
            (PATERR "*ANY* or *EVERY* cannot contain segment patterns"))
          [←(MATCHWM VAR (CONS (CDDAR PAT)
                               (CDR PAT))
                     (FUNCTION [LAMBDA (WHATMATCHED)
                                 (SET (CADAR PAT)
                                      WHATMATCHED]
                               (PAT]
          [<-(MATCHWM VAR (CONS (CDDAR PAT)
                                (CDR PAT))
                      (FUNCTION [LAMBDA (WM)
                                  (POSTPONESETQ (CADAR PAT)
                                                WM]
                                (PAT]
          [-> (HELP "REPLACE")
              (PROG1 (MATCHWM VAR (CONS (CDDAR PAT)
                                        (CDR PAT)))
                     (POSTPONEDREPLACE WHATMATCHED (CADAR PAT]
          [→ (HELP "REPLACE")
              (AND (MATCHWM VAR (CONS (CDDAR PAT)
                                      (CDR PAT)))
                   (REPLACE WHATMATCHED (CADAR PAT]
          (@ (MATCHWM VAR (CONS (CDDAR PAT)
                                (CDR PAT))
                      (CADAR PAT)))
          [!
            (COND
              ((NLISTP (CDAR PAT))
                (COND
                  ((NEQ (CDAR PAT)
                        (QUOTE &))
                    (PATERR "Invalid use of !")))
                (FRPLACA PAT (QUOTE $))
                (MATCH VAR PAT))
              (T
                (SELECTQ
                  (CADAR PAT)
                  [SUBPAT 

          (* (..1.. ! (..2..) ..3..) is the same as 
          (..1.. ..2.. ..3..))


                          (MATCH VAR (NCONC (CDAR PAT)
                                            (CDR PAT]
                  [=(AND VAR←(HEADP (EVAL (CDDAR PAT))
                                    VAR)
                         (MATCH VAR (CDR PAT]
                  ['(OR (LISTP (CDAR PAT))
                        (PATERR 
                           "!'ATOM is illegal in middle of pattern"))
                    (MATCH VAR (NCONC (for X in (CDDAR PAT)
                                         collect (CONS (QUOTE ')
                                                       X))
                                      (CDR PAT]
                  [* (HELP (QUTE                (* THIS SHUD BE HANDLD 
                                                IN PARSE)))
                     (MATCH VAR (CONS (CONS (QUOTE *)
                                            (CONS (QUOTE !)
                                                  (CDDAR PAT)))
                                      (CDR PAT]
                  [(← -> → <- @)
                    (HELP (QUOTE                (* THIS SHUD BE HANDLD 
                                                IN PARSE)))
                    (MATCH
                      VAR
                      (FRPLACA
                        PAT
                        (CONS (CADAR PAT)
                              (CONS (CADDR (CAR PAT))
                                    (CONS (QUOTE !)
                                          (CDDDR (CAR PAT]
                  (($PACKED$ ≠ ≠≠ *ANY* ! == *EVERY*)
                                                (* THIS SHUD BE HANDLD 
                                                IN PARSE)
                    (PATERR "ILLEGAL CONSTRUCT AFTER !"))
                  (HELP (QUOTE "CANT DO THIS ! YET")
                        PAT]
          (}(PATERR "Invalid use of }"))
          ($PACKED$ (MATCH (NTH VAR (EVAL (PAT:1::1)))
                           PAT::1))
          (HELP "INVALID PATTERN FOUND"])
)
  (LISPXPRINT (QUOTE IMATCHFNS)
              T)
  (RPAQQ IMATCHFNS (MATCHTOP MATCHELT POSTPONESETQ MATCH))
STOP