perm filename UMATCH.123[AID,LSP]2 blob sn#657741 filedate 1982-05-05 generic text, type C, neo UTF8

COMMENT ⊗ VALID 00005 PAGES C REC PAGE DESCRIPTION C00001 00001 C00002 00002 the matching function C00005 00003 Macros for Unification C00031 00004 Choice Macros C00036 00005 The Unification Matcher C00052 ENDMK C⊗; ;;;;;;;;;; the matching function ;;;;;;;;;; ;;; ;;; (arg 1) - p - pattern ;;; (arg 2) - d - data ;;; (arg 3) - alist - optional list of variables (* or ?) whose values ;;; are to be retained during the match, much like the ;;; = variables below. ;;; elements of a pattern: ;;; ? - matches anything ;;; * - matches one or more expressions ;;; ?<atom> - like "?", but sets ?<atom> to thing matched ;;; *<atom> - like "*", but sets *<atom> to list of things matched ;;; =<atom> - matched against value of <atom> ;;; (restrict <one of above ?-variables> <pred1> <pred2> .....) ;;; - the predi must eval to non-nil ;;; $r, ⊗r - same as RESTRICT ;;; (restrict <one of above *-variables> <pred1> <pred2> .....) ;;; - the predi must eval to non-nil when given the list ;;; that is being considered for that variable as its argument ;;; (irestrict <one of above *-variables> <pred1> <pred2> .....) ;;; - the predi must eval to non-nil when given each element of the list ;;; that is being considered for that variable as its argument ;;; (done incrementally). So %MATCH will apply these predicates as ;;; it scans the input. ;;; $ir,⊗ir - same as irestrict ;;; ;;; (%match p d <variables to retain>) attempts to match p against d ;;; (%continue-match p d <variables to retain>) attempts to get the next ;;; possible match between p and d (by different *-variable ;;; bindings. ;;*PAGE ;;; Macros for Unification (DECLARE (SETSYNTAX 35. 2 35.)) (DECLARE (SPECIAL %/#CONTINUE %/#CONTINUE-STACK %/#RETAIN %/#CE %/#ALIST COMPILE-MACROS)) (declare (special %/#full-predicate)) (setq %/#full-predicate ()) (declare (fasload struct fas dsk (mac lsp))) ;;; %/#CONTINUE is T if this is a rematch. %/#RETAIN says ;;; whether or not to save information for a rematch ;;; %/#CONTINUE-STACK saves * information for the rematch (SETQ %/#CONTINUE NIL %/#CONTINUE-STACK NIL %/#RETAIN NIL COMPILE-MACROS NIL) (MACRODEF SPECIAL-FORM (X) (LET QQQ ← X DO (COND ((%%SPECIAL-FORMP QQQ) '-SPECIAL-FORM-) (T QQQ))) ) (MACRODEF %%CHAR1 (ATOM) ;; returns the 1st character of an atom. (COND ((EQ (TYPEP ATOM) 'SYMBOL) (GETCHAR ATOM 1.)))) (MACRODEF REAL-ATOM (%/#X)(AND %/#X (ATOM %/#X))) (DECLARE (SPECIAL -SEEN-)) (DEFUN %%CHECK (L) ((LAMBDA(-SEEN-) (%%CHECK1 L)) ())) (DEFUN %%CHECK1 (L) (COND ((MEMQ L -SEEN-) L) ((ATOM L) L) ((HUNKP L) (PUSH L -SEEN-) L) ((EQ (CAR L) '-SPECIAL-FORM-) (CDR L)) (T (PUSH l -SEEN-) (CONS (%%CHECK1 (CAR L) ) (%%CHECK1 (CDR L)))))) ;(DEFUN %%CHECK (L) ; (COND ((ATOM L) L) ; ((EQ (CAR L) '-SPECIAL-FORM-) ; (CDR L)) ; (T (CONS (%%CHECK (CAR L))(%%CHECK (CDR L)))))) (MACRODEF ALL-TRUE (FUN %/#L) (APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (%Q%) (COND ((OR (RESTRICTP %Q%) (%%SPECIAL-FORMP %Q%) (FUNCALL FUN %Q%)) T)))) %/#L))) (MACRODEF RESTRICTP (%/#X) (AND (NOT (ATOM %/#X)) (MEMQ (CAR %/#X) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR)))) (MACRODEF EXCHANGE (X Y) ((LAMBDA (Q) (SETQ X Y) (SETQ Y Q)) X)) ;(DEFUN %REAL-FORM (X) ; (COND ((ATOM X) X) ; ((EQ (CAR X) '-SPECIAL-FORM-)(CDR X)) ; (X))) (DEFUN %%SPECIAL-FORMP (X) (COND (%/#FULL-PREDICATE ()) ((ATOM X) (OR (EQ X '-SPECIAL-FORM-) (MEMQ (%%CHAR1 X) '(? * =)))) (T (OR (EQ (CAR X) '-SPECIAL-FORM-) (RESTRICTP X)))) ) (MACRODEF CLAUSE-?-RESTRICTIONS (P D CP CD ALIST) (COND ((EQ (CADAR P) '?) ;;; normal case of ($r ? ...) (COND ((%%SPECIAL-FORMP (CAR D)) (SETQ P (CONS (CONS '-SPECIAL-FORM- (CAR P)) (CDR P))) (EXCHANGE P D)(EXCHANGE CP CD)) (T (SETQ P (CDR P) D (CDR D)))) (GO UMATCH)) ((EQ (%%CHAR1 (CADAR P)) '?) ;;; case of ($r ?foo ...) ((LAMBDA (%T%) (COND (%T% (SETQ P (CONS (SPECIAL-FORM (CDR %T%)) (CDR P))) (GO UMATCH)) (T (COND ( (*CATCH '%/#DECISION-POINT (COND ((%%SPECIAL-FORMP (CAR D)) (%%UMATCH D P CD CP (CONS (CONS (CADAR P) (CONS '-SPECIAL-FORM- (CAR D))) ALIST) NOBIND)) (T (%%UMATCH (CDR P)(CDR D) CP CD (CONS (CONS (CADAR P) (CAR D)) ALIST) NOBIND))) ) (OR NOBIND (SET (CADAR P) (%%CHECK (CAR D)))) (*THROW '%/#DECISION-POINT T )))))) (ASSQ (CADAR P) ALIST))))) (MACRODEF CLAUSE-*-RESTRICTIONS (P D CP CD ALIST) (COND ((EQ (CADAR P) '*) (COND ((NULL (CDR P)) (COND ((APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (Q) (COND ((FUNCALL Q D) T)))) (CDDAR P))) (COND ((%%SPECIAL-FORMP (CAR D)) (SETQ P (NCONS (CONS '-SPECIAL-FORM- (CAR P)))) (EXCHANGE P D)(EXCHANGE CP CD)) (T (SETQ P (CAR CP) D (CAR CD) CP (CDR CP) CD (CDR CD)))) (GO UMATCH)) (T (*THROW '%/#DECISION-POINT NIL )))) (T ((LAMBDA (L) (COND (%/#CONTINUE ;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL )) ;;; initialize for continuation (SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK) (SETQ %/#CONTINUE-STACK (CDR %/#CONTINUE-STACK)))) (SETQ D (DO ((L L (CDR L)) (D D (CDR D))) ((NULL L) D))) (COND ((NULL D) (SETQ P (CDR P)) (GO UMATCH)))) (T (SETQ L NIL))) ;;; try all possibilities (DO ((L L (NCONC L (NCONS (CAR D)))) (OD D OD) (OP P OP) (D D (CDR D)) (E (CONS NIL D) (CDR E))) ((NULL E) (*THROW '%/#DECISION-POINT NIL )) (COND ((APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (Q) (COND ((FUNCALL Q L) T)))) (CDDAR P))) (COND ((*CATCH '%/#DECISION-POINT (COND ((AND L (%%SPECIAL-FORMP (CAR OD))) (%%UMATCH OD OP CD CP ALIST NOBIND)) (T (%%UMATCH (CDR P) D CP CD ALIST NOBIND))) ) (AND %/#RETAIN (SETQ %/#CONTINUE-STACK (CONS L %/#CONTINUE-STACK))) (*THROW '%/#DECISION-POINT T ))))))) NIL)))) ((EQ (%%CHAR1 (CADAR P)) '*) ((LAMBDA (%T%) (COND (%T% (COND((APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (Q) (COND ((FUNCALL Q (CDR %T%)) T)))) (CDDAR P))) (SETQ P (APPEND (SPECIAL-FORM (CDR %T%)) (CDR P))) (GO UMATCH)) (T (*THROW '%/#DECISION-POINT NIL )))) ((NULL (CDR P)) (COND ((APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (Q) (COND ((FUNCALL Q D) T))))(CDDAR P))) (COND ( (*CATCH '%/#DECISION-POINT (COND ((%%SPECIAL-FORMP (CAR D)) (%%UMATCH D P CD CP (CONS (CONS (CADAR P) (CONS (CONS '-SPECIAL-FORM- (CAR D)) (CDR D))) ALIST) NOBIND)) (T (%%UMATCH (CAR CP) (CAR CD) (CDR CP) (CDR CD) (CONS (CONS (CADAR P) D) ALIST) NOBIND))) ) (OR NOBIND (SET (CADAR P) (%%CHECK D))) (*THROW '%/#DECISION-POINT T )) (T (*THROW '%/#DECISION-POINT NIL )))) (T (*THROW '%/#DECISION-POINT () )))) (T ((LAMBDA(L) (COND (%/#CONTINUE (SETQ L (SYMEVAL (CAR P))) (SETQ D (DO ((L L (CDR L)) (D D (CDR D))) ((NULL L) D))) (COND ((NULL D) (SETQ P (CDR P)) (GO UMATCH)))) (T (SETQ L NIL))) (DO ((L L (NCONC L (NCONS (CAR D)))) (OP P OP) (OD D OD) (D D (CDR D)) (E (CONS NIL D) (CDR E))) ((NULL E) (*THROW '%/#DECISION-POINT NIL )) (COND ((APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (Q) (COND((FUNCALL Q L) T)))) (CDDAR P))) (COND ((*CATCH '%/#DECISION-POINT (COND ((AND L (%%SPECIAL-FORMP (CAR OD))) (%%UMATCH OD OP CD CP (CONS (CONS (CADAR P) (CONS (CONS '-SPECIAL-FORM- (CAR OD)) (CDR L))) ALIST) NOBIND)) (T (%%UMATCH (CDR P) D CP CD (CONS (CONS (CADAR P) L) ALIST) NOBIND)) ) ) (OR NOBIND (SET (CADAR P) (%%CHECK L))) (*THROW '%/#DECISION-POINT T ))))))) NIL)))) (ASSQ (CADAR P) ALIST))))) (MACRODEF CLAUSE-*-IRESTRICTIONS (P D CP CD ALIST) (COND ((EQ (CADAR P) '*) (COND ((NULL (CDR P)) (COND ((APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (Q) (COND ((OR (RESTRICTP D) (ALL-TRUE Q D)) T)))) (CDDAR P))) (COND ((%%SPECIAL-FORMP (CAR D)) (SETQ P (NCONS (CONS '-SPECIAL-FORM- (CAR P)))) (EXCHANGE P D)(EXCHANGE CP CD)) (T (SETQ P (CAR CP) D (CAR CD) CP (CDR CP) CD (CDR CD)))) (GO UMATCH)) (T (*THROW '%/#DECISION-POINT NIL )))) (T ((LAMBDA (L) (COND (%/#CONTINUE ;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL )) ;;; initialize for continuation (SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK) (SETQ %/#CONTINUE-STACK (CDR %/#CONTINUE-STACK)))) (SETQ D (DO ((L L (CDR L)) (D D (CDR D))) ((NULL L) D))) (COND ((NULL D) (SETQ P (CDR P)) (GO UMATCH)))) (T (SETQ L NIL))) ;;; try all possibilities (DO ((L L (NCONC L (NCONS (CAR D)))) (F (CAR D)(CAR D)) (D D (CDR D)) (E (CONS NIL D) (CDR E))) ((NULL E) (*THROW '%/#DECISION-POINT NIL )) (COND ((APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (Q) (COND ((OR (NULL L) (RESTRICTP F) (%%SPECIAL-FORMP F) (FUNCALL Q F)) T)))) (CDDAR P))) (COND ((*CATCH '%/#DECISION-POINT (COND ((AND L (%%SPECIAL-FORMP (CAR D))) (%%UMATCH D (CDR P) CD CP ALIST NOBIND)) (T (%%UMATCH (CDR P) D CP CD ALIST NOBIND))) ) (AND %/#RETAIN (SETQ %/#CONTINUE-STACK (CONS L %/#CONTINUE-STACK))) (*THROW '%/#DECISION-POINT T ))))))) NIL)))) ((EQ (%%CHAR1 (CADAR P)) '*) ((LAMBDA (%T%) (COND (%T% (COND ((APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (Q) (COND ((OR (RESTRICTP %T%) (ALL-TRUE Q %T%)) T)))) (CDDAR P))) (COND ((*CATCH '%/#DECISION-POINT (%%UMATCH (CAR P)(CAR D) () () ALIST NOBIND) ) (SETQ P (APPEND (SPECIAL-FORM (CDR %T%)) (CDR P))) (GO UMATCH)) (T (*THROW '%/#DECISION-POINT () )))) (T (*THROW '%/#DECISION-POINT NIL )))) ((NULL (CDR P)) (COND ((APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (Q) (COND ((OR (RESTRICTP D) (ALL-TRUE Q D)) T))))(CDDAR P))) (COND ((OR (NOT (%%SPECIAL-FORMP (CAR D))) (*CATCH '%/#DECISION-POINT (%%UMATCH (CAR D)(CAR P) () () (CONS (CONS (CADAR P) (CONS (CONS '-SPECIAL-FORM- (CAR D)) (CDR D))) ALIST) NOBIND) )) (COND ((*CATCH '%/#DECISION-POINT (%%UMATCH (CAR CP) (CAR CD) (CDR CP) (CDR CD) (CONS (CONS (CADAR P) D) ALIST) NOBIND) ) (OR NOBIND (SET (CADAR P) (%%CHECK D))) (*THROW '%/#DECISION-POINT T )) (T (*THROW '%/#DECISION-POINT () )))) (T (*THROW '%/#DECISION-POINT NIL )))) (T (*THROW '%/#DECISION-POINT () )))) (T ((LAMBDA(L) (COND (%/#CONTINUE (SETQ L (SYMEVAL (CAR P))) (SETQ D (DO ((L L (CDR L)) (D D (CDR D))) ((NULL L) D))) (COND ((NULL D) (SETQ P (CDR P)) (GO UMATCH)))) (T (SETQ L NIL))) (DO ((L L (NCONC L (NCONS (CAR D)))) (F (CAR D)(CAR D)) (OD D OD) (OP P OP) (D D (CDR D)) (E (CONS NIL D) (CDR E))) ((NULL E) (*THROW '%/#DECISION-POINT NIL )) (COND ((APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (Q) (COND ((OR (NULL L) (RESTRICTP F) (%%SPECIAL-FORMP F) (FUNCALL Q F)) T)))) (CDDAR P))) (COND ((*CATCH '%/#DECISION-POINT (COND ((AND L (%%SPECIAL-FORMP (CAR OD))) (%%UMATCH OD OP CD CP (CONS (CONS (CADAR P) (CONS (CONS '-SPECIAL-FORM- (CAR OD)) (CDR L))) ALIST) NOBIND)) (T (%%UMATCH (CDR P) D CP CD (CONS (CONS (CADAR P) L) ALIST) NOBIND))) ) (OR NOBIND (SET (CADAR P) (%%CHECK L))) (*THROW '%/#DECISION-POINT T ))))))) NIL)))) (ASSQ (CADAR P) ALIST)) ))) (MACRODEF CLAUSE-?-VARIABLE (P D CP CD ALIST) ((LAMBDA (%T%) (COND (%T% (SETQ P (CONS (SPECIAL-FORM (CDR %T%)) (CDR P))) (GO UMATCH)) (T (COND ((*CATCH '%/#DECISION-POINT (COND ((%%SPECIAL-FORMP (CAR D)) (%%UMATCH D P CD CP (CONS (CONS (CAR P)(CAR D)) ALIST) NOBIND)) (T (%%UMATCH (CDR P)(CDR D) CP CD (CONS (CONS (CAR P)(CAR D))ALIST) NOBIND))) ) (OR NOBIND (SET (CAR P) (%%CHECK (CAR D)))) (*THROW '%/#DECISION-POINT T )) (T (*THROW '%/#DECISION-POINT () )))))) (ASSQ (CAR P) ALIST))) (MACRODEF CLAUSE-* (P D CP CD ALIST) (COND ((NULL (CDR P)) (COND ((%%SPECIAL-FORMP (CAR D)) (SETQ P (NCONS (CONS '-SPECIAL-FORM- (CAR P)))) (EXCHANGE P D)(EXCHANGE CP CD)) (T (SETQ P (CAR CP) D (CAR CD) CP (CDR CP) CD (CDR CD)))) (GO UMATCH)) (T ((LAMBDA (L) (COND (%/#CONTINUE ;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL )) ;;; initialize for continuation (SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK) (SETQ %/#CONTINUE-STACK (CDR %/#CONTINUE-STACK)))) (SETQ D (DO ((L L (CDR L)) (D D (CDR D))) ((NULL L) D))) (COND ((NULL D) (SETQ P (CDR P)) (GO UMATCH)))) (T (SETQ L NIL))) ;;; try all possibilities (DO ((L L (NCONC L (NCONS (CAR D)))) (D D (CDR D)) (E (CONS NIL D) (CDR E))) ((NULL E) (*THROW '%/#DECISION-POINT NIL )) (COND ((*CATCH '%/#DECISION-POINT (COND ((AND L (%%SPECIAL-FORMP (CAR D))) (%%UMATCH D (CDR P) CP CD ALIST NOBIND)) (T (%%UMATCH (CDR P) D CP CD ALIST NOBIND) )) ) (AND %/#RETAIN (SETQ %/#CONTINUE-STACK (CONS L %/#CONTINUE-STACK))) (*THROW '%/#DECISION-POINT T ))))) NIL)))) (MACRODEF CLAUSE-*-VARIABLE (P D CP CD ALIST) ((LAMBDA (%T%) (COND (%T% (SETQ P (APPEND (SPECIAL-FORM (CDR %T%)) (CDR P))) (GO UMATCH)) ((NULL (CDR P)) (COND ((*CATCH '%/#DECISION-POINT (COND ((%%SPECIAL-FORMP (CAR D)) (%%UMATCH D (CONS (CONS '-SPECIAL-FORM- (CAR P))(CDR P)) CD CP (CONS (CONS (CAR P) D) ALIST) NOBIND)) (T (%%UMATCH (CAR CP) (CAR CD) (CDR CP) (CDR CD) (CONS (CONS (CAR P) D) ALIST) NOBIND))) ) (OR NOBIND (SET (CAR P) (%%CHECK D))) (*THROW '%/#DECISION-POINT T )) (T (*THROW '%/#DECISION-POINT () )))) (T ((LAMBDA(L) (COND (%/#CONTINUE (SETQ L (SYMEVAL (CAR P))) (SETQ D (DO ((L L (CDR L)) (D D (CDR D))) ((NULL L) D))) (COND ((NULL D) (SETQ P (CDR P)) (GO UMATCH)))) (T (SETQ L NIL))) (DO ((L L (NCONC L (NCONS (CAR D)))) (D D (CDR D)) (E (CONS NIL D) (CDR E))) ((NULL E) (*THROW '%/#DECISION-POINT NIL )) (COND ((*CATCH '%/#DECISION-POINT (COND ((AND L (%%SPECIAL-FORMP (CAR D))) (%%UMATCH D (CDR P) CD CP (CONS (CONS (CAR P) L) ALIST) NOBIND)) (T (%%UMATCH (CDR P) D CP CD (CONS (CONS (CAR P) L) ALIST) NOBIND))) ) (OR NOBIND (SET (CAR P) (%%CHECK L))) (*THROW '%/#DECISION-POINT T ))))) NIL)))) (ASSQ (CAR P) ALIST)) ) (MACRODEF CLAUSE-=?-VARIABLE (P D CP CD ALIST) ((LAMBDA (%T%) (COND ((EQ (CAR %T%) '?) ((LAMBDA (VAR) ((LAMBDA (VAL) (COND (VAL (SETQ P (CONS (CDR VAL) (CDR P)))) (T (SETQ P (CONS (SYMEVAL VAR) (CDR P))))) (GO UMATCH)) (ASSQ VAR %/#ALIST))) (IMPLODE %T%))) (T ((LAMBDA (VAR) ((LAMBDA (VAL) (COND (VAL (SETQ P (APPEND (CDR VAL) (CDR P)))) (T (SETQ P (APPEND (SYMEVAL VAR) (CDR P))))) (GO UMATCH)) (ASSQ VAR %/#ALIST))) (IMPLODE %T%))))) (CDR (EXPLODE (CAR P))))) (MACRODEF CHOOSE-CLAUSE (P D CP CD ALIST) (LET ((PAT (CHOOSE-VAR (CAR P)))) (DO ((DAT (%%CHOOSE-FIRST PAT D) (%%CHOOSE-NEXT DAT))) ((EMPTY-CHOICE DAT) (*THROW '%/#DECISION-POINT ())) (COND ((*CATCH '%/#DECISION-POINT (%%UMATCH (CONS PAT (CDR P)) (NEXT-CHOICE DAT) CP CD ALIST NOBIND)) (*THROW '%/#DECISION-POINT T)))))) ;;; Choice Macros (DECLARE (SETQ DEFMACRO-FOR-COMPILING ()) (MAPEX T)) (EVAL-WHEN (COMPILE EVAL) (DEFSTRUCT CHOOSER PAST-CHOICES ORIGINAL-DATA VARIABLE PREDICATES CHOICE EMPTY SEARCH-LIST CONSTANTP)) (DEFMACRO CHOOSEP (X) `(AND (NOT (ATOM ,X)) (MEMQ (CAR ,X) '($CHOOSE $CH)))) (DEFMACRO CHOOSE-VAR (X) `(CADR ,X)) (DEFMACRO EMPTY-CHOICE (X) `(EMPTY ,X)) (DEFMACRO COPY (X) `(MAPCAR (FUNCTION (LAMBDA (X) X)) ,X))) (DEFUN %%CHOOSE-FIRST (P D) (%%CHOOSER (MAKE-CHOOSER PAST-CHOICES () ORIGINAL-DATA D CONSTANTP (ATOM P) SEARCH-LIST D CHOICE () EMPTY () VARIABLE (COND ((ATOM P) P) (T (CADR P))) PREDICATES (COND ((ATOM P) ()) (T (CDDR P)))))) (DEFUN %%CHOOSE-NEXT (OLD-CHOOSER) (%%CHOOSER (MAKE-CHOOSER PAST-CHOICES (PAST-CHOICES OLD-CHOOSER) ORIGINAL-DATA (ORIGINAL-DATA OLD-CHOOSER) CONSTANTP (CONSTANTP OLD-CHOOSER) SEARCH-LIST (SEARCH-LIST OLD-CHOOSER) CHOICE () EMPTY () VARIABLE (VARIABLE OLD-CHOOSER) PREDICATES (PREDICATES OLD-CHOOSER)))) (DEFMACRO NEXT-CHOICE (X) `(CHOICE ,X)) (DEFUN %%CHOOSER (CHOOSER) (LET ((P (VARIABLE CHOOSER)) (D (COPY (ORIGINAL-DATA CHOOSER))) (SL (COPY (SEARCH-LIST CHOOSER)))) (LET ((CH ())) (COND ((CONSTANTP CHOOSER) (COND ((SETQ SL (MEMQ P SL)) (SETQ CH `(,P . ,(DELQ P D))) (COND ((MEMBER CH (PAST-CHOICES CHOOSER)) (SETF (EMPTY CHOOSER) T)) (T (SETF (CHOICE CHOOSER) CH) (SETF (SEARCH-LIST CHOOSER) (CDR SL)) (SETF (PAST-CHOICES CHOOSER) `(,CH . ,(PAST-CHOICES CHOOSER)))))) (T (SETF (EMPTY CHOOSER) T)))) (T (LET ((CAND (%%SEARCH (PREDICATES CHOOSER) SL))) (COND (CAND (SETQ CH `(,(CAR CAND) . ,(DELQ (CAR CAND) D))) (COND ((MEMBER CH (PAST-CHOICES CHOOSER)) (SETF (EMPTY CHOOSER) T)) (T (SETF (CHOICE CHOOSER) CH) (SETF (SEARCH-LIST CHOOSER) (CDR CAND)) (SETF (PAST-CHOICES CHOOSER) `(,CH . ,(PAST-CHOICES CHOOSER)))))) (T (SETF (EMPTY CHOOSER) T)))))))) CHOOSER) (DEFUN %%SEARCH (PREDS L) (DO ((L L (CDR L))) ((NULL L) ()) (COND ((APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (F) (FUNCALL F (CAR L)))) PREDS)) (RETURN L))))) (MACRODEF CHOOSE-CLAUSE (P D CP CD ALIST) (LET ((PAT (CHOOSE-VAR (CAR P)))) (DO ((DAT (%%CHOOSE-FIRST PAT D) (%%CHOOSE-NEXT DAT))) ((EMPTY-CHOICE DAT) (*THROW '%/#DECISION-POINT ())) (COND ((*CATCH '%/#DECISION-POINT (%%UMATCH (CONS PAT (CDR P)) (NEXT-CHOICE DAT) CP CD ALIST)) (*THROW '%/#DECISION-POINT T)))))) ;;; The Unification Matcher ;;; Matches 2 patterns. (declare (special %statistics %calls)(fixnum %calls)) (setq %statistics () %calls 0) (defun %calls () %calls) (defun %statistics (x)(and x (setq %calls 0))(setq %statistics x)) ;;; (%UMATCH <pat> <data> <initial alist, optional>) (DEFUN %UMATCH %/#n (AND %STATISTICS (SETQ %CALLS (1+ %CALLS))) ((LAMBDA(%/#CONTINUE) (SETQ %/#CONTINUE-STACK NIL) (*CATCH '%/#DECISION-POINT (%%UMATCH (ARG 1) (ARG 2) NIL NIL (COND ((< 2 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q)))) (ARG 3)))) ()) )) NIL)) ;;; (%CONTINUE-UMATCH <pat> <data> <* stack> <intitial alist, optional>) (DEFUN %CONTINUE-UMATCH %/#n ((LAMBDA(%/#CONTINUE) (SETQ %/#CONTINUE-STACK (ARG 3)) (*CATCH '%/#DECISION-POINT (%%UMATCH (ARG 1)(ARG 2) NIL NIL (COND ((< 3 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q)))) (ARG 4)))) ()) )) T)) ;;; (%UMATCH-NOBIND <pat> <data> <initial alist, optional>) (DEFUN %UMATCH-NOBIND %/#n ((LAMBDA(%/#CONTINUE) (SETQ %/#CONTINUE-STACK NIL) (*CATCH '%/#DECISION-POINT (%%UMATCH (ARG 1) (ARG 2) NIL NIL (COND ((< 2 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q)))) (ARG 3)))) T) )) NIL)) ;;; (%%/#CONTINUE-UMATCH-NOBIND <pat> <data> <* stack> <intitial alist, optional>) (DEFUN %%/#CONTINUE-UMATCH-NOBIND %/#n ((LAMBDA(%/#CONTINUE) (SETQ %/#CONTINUE-STACK (ARG 3)) (*CATCH '%/#DECISION-POINT (%%UMATCH (ARG 1)(ARG 2) NIL NIL (COND ((< 3 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q)))) (ARG 4)))) T) )) T)) ;;; %/#P is the pattern ;;; %/#D is the data ;;; %/#CP is the pattern to UMATCH against %/#CD if %/#P and %/#D UMATCH (i.e. a continuation) ;;; %/#CD is the data for the continuation ;;; ALIST is the current alist (DEFUN %%UMATCH (%/#P %/#D %/#CP %/#CD %/#ALIST NOBIND) (PROG NIL UMATCH (OR (COND ;;; no more pattern ((AND (NULL %/#P) (NULL %/#CP)) ;;; so there had better be no more data, unless there are some * vars etc (COND ((AND (NULL %/#D)(NULL %/#CD)) ;;; if this is a reUMATCH, we back up for next try (COND (%/#CONTINUE (SETQ %/#CONTINUE NIL) (*THROW '%/#DECISION-POINT NIL )) ;;; otherwise success ((*THROW '%/#DECISION-POINT T )))) ;;; more data loses in some cases (T (COND ((OR (ATOM %/#D) (MEMQ (CAR %/#D) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR)) (CHOOSEP %/#D)) ;;; if %/#D=?<var> or = nil (SETQ %/#D (NCONS %/#D) %/#P '(NIL)) (GO UMATCH)) ((EQ (CAR %/#D) '*) ;;; %/#D=(* ...) could work if (CDR %/#D) is all *-variables (SETQ %/#D (CDR %/#D)) (GO UMATCH)) ((EQ (%%CHAR1 (CAR %/#D)) '*) ;;; we succeed if (CAR %/#D) = (*<var> ...) ;;; and *<var> UMATCHed 0 elements. ((LAMBDA(%T%) (COND (%T% (SETQ %/#D (APPEND (SPECIAL-FORM (CDR %T%)) (CDR %/#D))) (GO UMATCH)) (T (COND ((*CATCH '%/#DECISION-POINT (%%UMATCH NIL (CDR %/#D) %/#CP %/#CD (CONS (CONS (CAR %/#D) NIL) %/#ALIST) NOBIND) ) (OR NOBIND (SET (CAR %/#D) NIL)) (*THROW '%/#DECISION-POINT T )) (T (*THROW '%/#DECISION-POINT () )))))) (ASSQ (CAR %/#D) %/#ALIST))) (T (*THROW '%/#DECISION-POINT NIL )))))) ((NULL %/#P) ;;; if %/#P is null, but %/#D isn't, something is wrong sometimes (COND (%/#D (COND ((OR (ATOM %/#D) (MEMQ (CAR %/#D) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR)) (CHOOSEP %/#D)) ;;; if %/#D=?<var> or = nil (SETQ %/#D (NCONS %/#D) %/#P '(NIL)) (GO UMATCH)) ((EQ (CAR %/#D) '*) ;;; %/#D=(* ...) could work if (CDR %/#D) is all *-variables (SETQ %/#D (CDR %/#D)) (GO UMATCH)) ((EQ (%%CHAR1 (CAR %/#D)) '*) ;;; we succeed if (CAR %/#D) = (*<var> ...) ;;; and *<var> UMATCHed 0 elements. ((LAMBDA(%T%) (COND (%T% (SETQ %/#D (APPEND (SPECIAL-FORM (CDR %T%)) (CDR %/#D))) (GO UMATCH)) (T (COND ((*CATCH '%/#DECISION-POINT (%%UMATCH NIL (CDR %/#D) %/#CP %/#CD (CONS (CONS (CAR %/#D) NIL) %/#ALIST) NOBIND) ) (OR NOBIND (SET (CAR %/#D) NIL)) (*THROW '%/#DECISION-POINT T )) (T (*THROW '%/#DECISION-POINT () ))))) ) (ASSQ (CAR %/#D) %/#ALIST))) (T (*THROW '%/#DECISION-POINT NIL )))) (T (SETQ %/#P (CAR %/#CP) %/#D (CAR %/#CD) %/#CP (CDR %/#CP) %/#CD (CDR %/#CD)) (GO UMATCH)))) ((AND (NULL %/#D) (NOT (RESTRICTP (CAR %/#P)))) ;;; if %/#D is null and %/#P isn't, we can still win (COND ((OR (ATOM %/#P) (MEMQ (CAR %/#P) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR)) (CHOOSEP %/#D)) ;;; if %/#P=?<var> or = nil (SETQ %/#P (NCONS %/#P) %/#D '(NIL)) (GO UMATCH)) ((EQ (CAR %/#P) '*) ;;; %/#P=(* ...) could work if (CDR %/#P) is all *-variables (SETQ %/#P (CDR %/#P)) (GO UMATCH)) ((EQ (%%CHAR1 (CAR %/#P)) '*) ;;; we succeed if (CAR %/#P) = (*<var> ...) and *<var> UMATCHed 0 elements. ((LAMBDA(%T%) (COND (%T% (SETQ %/#P (APPEND (SPECIAL-FORM (CDR %T%)) (CDR %/#P))) (GO UMATCH)) (T (COND ((*CATCH '%/#DECISION-POINT (%%UMATCH (CDR %/#P) NIL %/#CP %/#CD (CONS (CONS (CAR %/#P) NIL) %/#ALIST) NOBIND) ) (OR NOBIND (SET (CAR %/#P) NIL)) (*THROW '%/#DECISION-POINT T )) (T (*THROW '%/#DECISION-POINT () )))))) (ASSQ (CAR %/#P) %/#ALIST))) )) ((OR (REAL-ATOM %/#P) (REAL-ATOM %/#D)) ;;; here we listify things if necessary (SETQ %/#P (NCONS %/#P) %/#D (NCONS %/#D)) (GO UMATCH)) ;;; ? restrictions ((AND (NOT (ATOM (CAR %/#P))) (MEMQ (CAAR %/#P) '($R RESTRICT ⊗R)) (EQ (%%CHAR1 (CADAR %/#P)) '?) (NOT (NULL %/#D)) (APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (%/#PRED) (COND ((OR (RESTRICTP (CAR %/#D)) (%%SPECIAL-FORMP (CAR %/#D)) (FUNCALL %/#PRED (CAR %/#D))) T)))) (CDDAR %/#P)))) (COND ((EQ (%%CHAR1 (CADAR %/#P)) '?) (CLAUSE-?-RESTRICTIONS %/#P %/#D %/#CP %/#CD %/#ALIST)) ((EQ (%%CHAR1 (CADAR %/#P)) '=) ((LAMBDA (VAR) ((LAMBDA (VAL) (COND (VAL (SETQ %/#P (CONS (LIST (CAAR %/#P) VAR (CDDAR %/#P)) (CDR %/#P)))) (T (SETQ %/#P (CONS (LIST (CAAR %/#P) VAR (CDDAR %/#P)) (CDR %/#P)) %/#ALIST (CONS (CONS VAR (SYMEVAL VAR)) %/#ALIST))))) (ASSQ VAR %/#ALIST))) (IMPLODE (CDR (EXPLODE (CADAR %/#P))))) (GO UMATCH)) (T (*THROW '%/#DECISION-POINT () )))) ((AND (NOT (ATOM (CAR %/#P))) (MEMQ (CAAR %/#P) '($R RESTRICT ⊗R))) (CLAUSE-*-RESTRICTIONS %/#P %/#D %/#CP %/#CD %/#ALIST)) ((AND (NOT (ATOM (CAR %/#P))) (MEMQ (CAAR %/#P) '($IR IRESTRICT ⊗IR))) (CLAUSE-*-IRESTRICTIONS %/#P %/#D %/#CP %/#CD %/#ALIST)) ((EQ (CAR %/#P) '*) ;;; (* ...) (CLAUSE-* %/#P %/#D %/#CP %/#CD %/#ALIST)) ((EQ (%%CHAR1 (CAR %/#P)) '*) ;;; similar for (*foo ...) (CLAUSE-*-VARIABLE %/#P %/#D %/#CP %/#CD %/#ALIST)) ((EQ (%%CHAR1 (CAR %/#P)) '=) ;;; (=?foo ...) (CLAUSE-=?-VARIABLE %/#P %/#D %/#CP %/#CD %/#ALIST)) ((AND (NOT (ATOM (CAR %/#D))) (MEMQ (CAAR %/#D) '($R RESTRICT ⊗R)) (APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (%/#PRED) (COND ((OR (RESTRICTP (CAR %/#P)) (%%SPECIAL-FORMP (CAR %/#P)) (FUNCALL %/#PRED (CAR %/#P))) T)))) (CDDAR %/#D)))) (COND ((EQ (%%CHAR1 (CADAR %/#D)) '?) (COND ((NULL %/#P)(*THROW '%/#DECISION-POINT ())) (T (CLAUSE-?-RESTRICTIONS %/#D %/#P %/#CD %/#CP %/#ALIST)))) ((EQ (%%CHAR1 (CADAR %/#P)) '=) ((LAMBDA (VAR) ((LAMBDA (VAL) (COND (VAL (SETQ %/#P (CONS (LIST (CAAR %/#P) VAR (CDDAR %/#P)) (CDR %/#P)))) (T (SETQ %/#P (CONS (LIST (CAAR %/#P) VAR (CDDAR %/#P)) (CDR %/#P)) %/#ALIST (CONS (CONS VAR (SYMEVAL VAR)) %/#ALIST))))) (ASSQ VAR %/#ALIST))) (IMPLODE (CDR (EXPLODE (CADAR %/#P))))) (GO UMATCH)) (T (*THROW '%/#DECISION-POINT () )))) ((AND (NOT (ATOM (CAR %/#D))) (MEMQ (CAAR %/#D) '($R RESTRICT ⊗R))) (CLAUSE-*-RESTRICTIONS %/#D %/#P %/#CD %/#CP %/#ALIST)) ((AND (NOT (ATOM (CAR %/#D))) (MEMQ (CAAR %/#D) '($IR IRESTRICT ⊗IR))) (CLAUSE-*-IRESTRICTIONS %/#D %/#P %/#CD %/#CP %/#ALIST)) ((EQ (CAR %/#D) '*) ;;; (* ...) (CLAUSE-* %/#D %/#P %/#CD %/#CP %/#ALIST)) ((EQ (%%CHAR1 (CAR %/#D)) '*) ;;; similar for (*foo ...) (CLAUSE-*-VARIABLE %/#D %/#P %/#CD %/#CP %/#ALIST)) ((EQ (%%CHAR1 (CAR %/#D)) '=) ;;; (=?foo ...) (CLAUSE-=?-VARIABLE %/#D %/#P %/#CD %/#CP %/#ALIST)) ((OR (EQUAL (CAR %/#P) (CAR %/#D)) (EQ (CAR %/#P) '?) (EQ (CAR %/#D) '?)) ;;; easiest case (SETQ %/#P (CDR %/#P) %/#D (CDR %/#D)) (GO UMATCH)) ((EQ (%%CHAR1 (CAR %/#P)) '?) ;;; (?foo ...) (CLAUSE-?-VARIABLE %/#P %/#D %/#CP %/#CD %/#ALIST)) ((EQ (%%CHAR1 (CAR %/#D)) '?) ;;; (?foo ...) (CLAUSE-?-VARIABLE %/#D %/#P %/#CD %/#CP %/#ALIST)) ((CHOOSEP (CAR %/#P)) (CHOOSE-CLAUSE %/#P %/#D %/#CP %/#CD %/#ALIST)) ((CHOOSEP (CAR %/#D)) (CHOOSE-CLAUSE %/#D %/#P %/#CD %/#CP %/#ALIST)) ((AND (NOT (ATOM (CAR %/#P))) (OR (NULL (CAR %/#D))(NOT (ATOM (CAR %/#D))))) ;;; the big recursion ;;; notice that we want nil to be a list here, not an atom ;;; since ((*) ...) (nil ...) needs a chance (SETQ %/#CP (CONS (CDR %/#P) %/#CP) %/#CD (CONS (CDR %/#D) %/#CD) %/#P (CAR %/#P) %/#D (CAR %/#D)) (GO UMATCH))) (*THROW '%/#DECISION-POINT () )))) ;;*page