perm filename TVR.LSP[AID,LSP] blob sn#688797 filedate 1982-12-07 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 C00035 00004 Choice Macros C00040 00005 The Unification Matcher C00059 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. ;;; (catch-match <form>) will intercept any backtracks, used in RESTRICT ;;; clauses. ;;*PAGE ;;; Macros for Unification (DECLARE (SETSYNTAX 35. 2 35.)) (DECLARE (SPECIAL %/#CONTINUE %/#CONTINUE-STACK %/#RETAIN %/#CE %/#ALIST COMPILE-MACROS UMATCH-ALIST)) (declare (special %/#full-predicate %/#OCCURS)) (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 %/#OCCURS () UMATCH-ALIST ()) (DEFUN %%OCCURS (X L) (COND ((MEMQ L (CDR (ASSQ X %/#OCCURS))) T) ((EQ X L) ()) (T (%%OCCURS1 X L L)))) (DEFUN %%OCCURS1 (X L TOP) (COND ((NULL L) ()) ((EQ X L) (LET ((ENTRY (ASSQ X %/#OCCURS))) (COND (ENTRY (NCONC ENTRY `(,TOP))) (T (PUSH `(,X . (,TOP)) %/#OCCURS)))) T) ((ATOM L) ()) (T (OR (%%OCCURS1 X (CAR L) TOP) (%%OCCURS1 X (CDR L) TOP))))) (MACRODEF MAKE-SPECIAL-FORM (X) (CONS '-SPECIAL-FORM- X)) (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)) ((MEMQ (CAR L) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR $CH $CHOOSE)) (CADR L)) (T (PUSH l -SEEN-) (CONS (%%CHECK1 (CAR L) ) (%%CHECK1 (CDR L)))))) (MACRODEF PROCESSED-SPECIAL-FORMP (X) (LET ((Q X)) (COND ((ATOM Q) ()) (T (EQ (CAR Q) '-SPECIAL-FORM-))))) (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 %%SPECIAL-FORMP (X) (COND (%/#FULL-PREDICATE ()) ((ATOM X) (OR (EQ X '-SPECIAL-FORM-) (AND (NOT (EQ X '=)) (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 (LET ((SPECP ())(RESTRP ())) (COND ( (*CATCH '%/#DECISION-POINT (COND ((%%OCCURS (CADAR P) (COND ((RESTRICTP (CAR D)) (CADAR D)) (T (CAR D)))) ()) ((%%SPECIAL-FORMP (CAR D)) (LET ((G (GENSYM)) (ALIST ALIST)) (COND ((RESTRICTP (CAR D)) (COND ((EQ (%%CHAR1 (CADAR D)) '?) (SETQ SPECP T RESTRP T) (PUSH (CONS (CADAR D) G) ALIST)))) ((EQ (%%CHAR1 (CAR D)) '?) (SETQ SPECP T) (PUSH (CONS (CAR D) G) ALIST))) (COND ((PROCESSED-SPECIAL-FORMP (CAR D)) (%%UMATCH (CDR D) (CDR P) CD CP (CONS (CONS (CAR P) G) ALIST) NOBIND)) (T (%%UMATCH D P CD CP (CONS (CONS (CAR P) G) ALIST) NOBIND))))) (T (%%UMATCH (CDR P)(CDR D) CP CD (CONS (CONS (CADAR P) (CAR D)) ALIST) NOBIND))) ) (CASEQ NOBIND (PAIR (PUSH `(,(CADAR P) . ,(%%CHECK (CAR D))) UMATCH-ALIST) (COND (SPECP (COND (RESTRP (PUSH `(,(CADAR D) . ,(%%CHECK (CADAR P))) UMATCH-ALIST)) (T (PUSH `(,(CAR D) . ,(%%CHECK (CADAR P))) UMATCH-ALIST)))))) (() (SET (CADAR P) (%%CHECK (CAR D))) (COND (SPECP (COND (RESTRP (SET (CADAR D) (%%CHECK (CADAR P)))) (T (SET (CAR D) (%%CHECK (CADAR P)))))))) (T ())) (*THROW '%/#DECISION-POINT T )) (T (*THROW '%/#DECISION-POINT ()))))))) (ASSQ (CADAR P) ALIST))))) (MACRODEF CLAUSE-*-RESTRICTIONS (P D CP CD ALIST) (COND ((EQ (CADAR P) '*) ((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)))) (SP (%%SPECIAL-FORMP (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 SP (*CATCH '%/#DECISION-POINT (%%UMATCH L (NCONS (MAKE-SPECIAL-FORM (CAR P))) CP CD (CONS (CONS (CAR P) L) 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 )))) (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)))) (SP (%%SPECIAL-FORMP (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)) ) ) (AND SP (*CATCH '%/#DECISION-POINT (%%UMATCH L (NCONS (MAKE-SPECIAL-FORM (CAR P))) CP CD (CONS (CONS (CAR P) L) ALIST) NOBIND))) (CASEQ NOBIND (PAIR (PUSH `(,(CADAR P) . ,(%%CHECK L)) UMATCH-ALIST)) (() (SET (CADAR P) (%%CHECK L))) (T ())) (*THROW '%/#DECISION-POINT T ))))))) NIL)))) (ASSQ (CADAR P) ALIST))))) (MACRODEF CLAUSE-*-IRESTRICTIONS (P D CP CD ALIST) (COND ((EQ (CADAR P) '*) ((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)) (SP (%%SPECIAL-FORMP (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 SP (*CATCH '%/#DECISION-POINT (%%UMATCH L (NCONS (MAKE-SPECIAL-FORM (CAR P))) CP CD (CONS (CONS (CAR P) L) 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 )))) (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) (SP (%%SPECIAL-FORMP (CAR D))) (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))) ) (AND SP (*CATCH '%/#DECISION-POINT (%%UMATCH L (NCONS (MAKE-SPECIAL-FORM (CAR P))) CP CD (CONS (CONS (CAR P) L) ALIST) NOBIND))) (CASEQ NOBIND (PAIR (PUSH `(,(CADAR P) . ,(%%CHECK L)) UMATCH-ALIST)) (() (SET (CADAR P) (%%CHECK L))) (T ())) (*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 (LET ((SPECP ()) (RESTRP ())) (COND ((*CATCH '%/#DECISION-POINT (COND ((%%OCCURS (CAR P) (COND ((RESTRICTP (CAR D)) (CADAR D)) (T (CAR D)))) ()) ((%%SPECIAL-FORMP (CAR D)) (LET ((G (GENSYM)) (ALIST ALIST)) (COND ((RESTRICTP (CAR D)) (COND ((EQ (%%CHAR1 (CADAR D)) '?) (SETQ SPECP T RESTRP T) (PUSH (CONS (CADAR D) G) ALIST)))) ((EQ (%%CHAR1 (CAR D)) '?) (SETQ SPECP T) (PUSH (CONS (CAR D) G) ALIST))) (COND ((PROCESSED-SPECIAL-FORMP (CAR D)) (%%UMATCH (CDR D) (CDR P) CD CP (CONS (CONS (CAR P) G) ALIST) NOBIND)) (T (%%UMATCH D P CD CP (CONS (CONS (CAR P) G) ALIST) NOBIND))))) (T (%%UMATCH (CDR P)(CDR D) CP CD (CONS (CONS (CAR P)(CAR D))ALIST) NOBIND))) ) (CASEQ NOBIND (PAIR (PUSH `(,(CAR P) . ,(%%CHECK (CAR D))) UMATCH-ALIST) (COND (SPECP (COND (RESTRP (PUSH `(,(CADAR D) . ,(%%CHECK (CAR P))) UMATCH-ALIST)) (T (PUSH `(,(CAR D) . ,(%%CHECK (CAR P))) UMATCH-ALIST)))))) (() (SET (CAR P) (%%CHECK (CAR D))) (COND (SPECP (COND (RESTRP (SET (CADAR D) (%%CHECK (CAR P)))) (T (SET (CAR D) (%%CHECK (CAR P)))))))) (T ())) (*THROW '%/#DECISION-POINT T )) (T (*THROW '%/#DECISION-POINT () ))))))) (ASSQ (CAR P) ALIST))) (MACRODEF CLAUSE-* (P D CP CD ALIST) ((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)) (SP (%%SPECIAL-FORMP (CAR 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 SP (*CATCH '%/#DECISION-POINT (%%UMATCH L (NCONS (MAKE-SPECIAL-FORM (CAR P))) CP CD (CONS (CONS (CAR P) L) 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)) (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)) (SP (%%SPECIAL-FORMP (CAR D))) (E (CONS NIL D) (CDR E))) ((NULL E) (*THROW '%/#DECISION-POINT NIL )) (COND ((*CATCH '%/#DECISION-POINT (%%UMATCH (CDR P) D CP CD (CONS (CONS (CAR P) L) ALIST) NOBIND) ) (AND SP (*CATCH '%/#DECISION-POINT (%%UMATCH L (NCONS (MAKE-SPECIAL-FORM (CAR P))) CP CD (CONS (CONS (CAR P) L) ALIST) NOBIND))) (CASEQ NOBIND (PAIR (PUSH `(,(CAR P) . ,(%%CHECK L)) UMATCH-ALIST)) (() (SET (CAR P) (%%CHECK L))) (T ())) (*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))))) ;;; Choice Macros (DEFMACRO CATCH-MATCH (FORM) `(*CATCH '%/#DECISION-POINT ,FORM)) (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 %%UCHOOSE-FIRST (P D) (%%UCHOOSER (MAKE-CHOOSER PAST-CHOICES () ORIGINAL-DATA D CONSTANTP (AND (ATOM P) (NOT (EQ (%%CHAR1 P) '?))) SEARCH-LIST D CHOICE () EMPTY () VARIABLE (COND ((ATOM P) P) (T (CADR P))) PREDICATES (COND ((ATOM P) ()) ((RESTRICTP P) (CDDR P)))))) (DEFUN %%UCHOOSE-NEXT (OLD-CHOOSER) (%%UCHOOSER (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)) (DECLARE (*LEXPR %UMATCH)) (DEFUN %MATCH-MEMQ (P L) (DO ((L L (CDR L))) ((NULL L) ()) (COND ((%UMATCH P (CAR L)) (RETURN L))))) (DEFUN %%UCHOOSER (CHOOSER) (LET ((P (VARIABLE CHOOSER)) (D (COPY (ORIGINAL-DATA CHOOSER))) (SL (COPY (SEARCH-LIST CHOOSER)))) (LET ((CH ())) (COND ((CONSTANTP CHOOSER) (COND ((SETQ SL (%MATCH-MEMQ P SL)) (SETQ CH `(,(CAR SL) . ,(DELQ (CAR SL) 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 (%%USEARCH (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 %%USEARCH (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 (%%UCHOOSE-FIRST PAT D) (%%UCHOOSE-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)))))) ;;; 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 %/#OCCURS) (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 NIL)) ;;; (%CONTINUE-UMATCH <pat> <data> <* stack> <intitial alist, optional>) (DEFUN %CONTINUE-UMATCH %/#n ((LAMBDA(%/#CONTINUE %/#OCCURS) (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 %/#OCCURS) (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 NIL)) ;;; (%UMATCH-PAIR <pat> <data> <initial alist, optional>) (DEFUN %UMATCH-PAIR %/#n ((LAMBDA(%/#CONTINUE %/#OCCURS) (SETQ %/#CONTINUE-STACK NIL UMATCH-ALIST ()) (*CATCH '%/#DECISION-POINT (%%UMATCH (ARG 1) (ARG 2) NIL NIL (COND ((< 2 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q)))) (ARG 3)))) 'PAIR) )) NIL NIL)) ;;; (%%/#CONTINUE-UMATCH-NOBIND <pat> <data> <* stack> <intitial alist, optional>) (DEFUN %%/#CONTINUE-UMATCH-NOBIND %/#n ((LAMBDA(%/#CONTINUE %/#OCCURS) (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 ())) ;;; (%%/#CONTINUE-UMATCH-PAIR <pat> <data> <* stack> <intitial alist, optional>) (DEFUN %%/#CONTINUE-UMATCH-PAIR %/#n ((LAMBDA(%/#CONTINUE %/#OCCURS) (SETQ %/#CONTINUE-STACK (ARG 3) UMATCH-ALIST ()) (*CATCH '%/#DECISION-POINT (%%UMATCH (ARG 1)(ARG 2) NIL NIL (COND ((< 3 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q)))) (ARG 4)))) 'PAIR) )) 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) ) (CASEQ NOBIND (PAIR (PUSH `(,(CAR %/#D) . ()) UMATCH-ALIST)) (() (SET (CAR %/#D) ())) (T ())) (*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) ) (CASEQ NOBIND (PAIR (PUSH `(,(CAR %/#D) . ()) UMATCH-ALIST)) (() (SET (CAR %/#D) ())) (T ())) (*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) ) (CASEQ NOBIND (PAIR (PUSH `(,(CAR %/#P) . ()) UMATCH-ALIST)) (() (SET (CAR %/#P) ())) (T ())) (*THROW '%/#DECISION-POINT T )) (T (*THROW '%/#DECISION-POINT () )))))) (ASSQ (CAR %/#P) %/#ALIST))) )) ((OR (REAL-ATOM %/#P) (REAL-ATOM %/#D) (RESTRICTP %/#P)(RESTRICTP %/#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)) ((AND (NOT (EQ (CADAR %/#P) '=)) (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)) ((AND (NOT (EQ (CAR %/#P) '=)) (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)))) ((AND (NOT (EQ (CADAR %/#P) '=)) (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)) ((AND (NOT (EQ (CAR %/#D) '=)) (EQ (%%CHAR1 (CAR %/#D)) '=)) ;;; (=?foo ...) (CLAUSE-=?-VARIABLE %/#D %/#P %/#CD %/#CP %/#ALIST)) ((OR (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)) ((EQ (CAR %/#P) (CAR %/#D)) ;;; easiest case (SETQ %/#P (CDR %/#P) %/#D (CDR %/#D)) (GO UMATCH)) ((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