matcher: support loose mode for structures.

* share/txr/stdlib/match.tl (compile-struct-match):
Allow a pattern instead of a struct type name, in which
case the object can be of any struct type which has
the slots required by the pattern.

* txr.1: Documented.

2 files changed, 113 insertions, 26 deletions

diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index 9648901c..0a975134 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -59,26 +59,54 @@
 (defvar *match-form*)
 
 (defun compile-struct-match (struct-pat obj-var)
-  (let* ((required-type (cadr struct-pat))
-         (slot-pairs (plist-to-alist (cddr struct-pat)))
-         (required-slots [mapcar car slot-pairs])
-         (slot-gensyms [mapcar gensym required-slots])
-         (slot-patterns [mapcar cdr slot-pairs])
-         (slot-matches [mapcar compile-match slot-patterns slot-gensyms])
-         (slot-val-exprs [mapcar (ret ^(slot ,obj-var ',@1))
-                                 required-slots])
-         (guard (new match-guard
-                     vars slot-gensyms
-                     var-exprs slot-val-exprs
-                     guard-expr  ^(subtypep (typeof ,obj-var)
-                                            ',required-type))))
-    (new compiled-match
-         pattern struct-pat
-         obj-var obj-var
-         guard-chain (cons guard (mappend .guard-chain slot-matches))
-         test-expr ^(and ,*(mapcar .test-expr slot-matches))
-         vars [mappend .vars slot-matches]
-         var-exprs [mappend .var-exprs slot-matches])))
+  (tree-bind (op required-type . pairs) struct-pat
+    (let* ((loose-p (not (bindable required-type)))
+           (slot-pairs (plist-to-alist pairs))
+           (required-slots [mapcar car slot-pairs])
+           (slot-gensyms [mapcar gensym required-slots])
+           (type-gensym (if loose-p
+                          (gensym "type-")))
+           (slot-patterns [mapcar cdr slot-pairs])
+           (slot-matches [mapcar compile-match slot-patterns slot-gensyms])
+           (type-match (if loose-p
+                         (compile-match required-type type-gensym)))
+           (all-matches (if loose-p
+                          (cons type-match slot-matches)
+                          slot-matches))
+           (slot-val-exprs [mapcar (ret ^(slot ,obj-var ',@1)) required-slots])
+           (guard0 (if loose-p
+                     (new match-guard
+                          vars (list type-gensym)
+                          var-exprs (list ^(struct-type ,obj-var))
+                          guard-expr ^(structp ,obj-var))))
+           (guard1 (new match-guard
+                        vars slot-gensyms
+                        var-exprs slot-val-exprs
+                        guard-expr (if loose-p
+                                     ^(and ,*(mapcar
+                                               (ret ^(slotp ,type-gensym ',@1))
+                                               required-slots))
+                                     ^(subtypep (typeof ,obj-var)
+                                                ',required-type)))))
+      (unless loose-p
+        (let ((type (find-struct-type required-type)))
+          (if type
+            (each ((slot required-slots))
+              (unless (slotp type slot)
+                (compile-defr-warning *match-form* ^(slot . ,slot)
+                                      "~s has no slot ~s"
+                                      required-type slot)))
+            (compile-defr-warning *match-form* ^(struct-type . ,required-type)
+                                  "no such struct type: ~s"
+                                  required-type))))
+      (new compiled-match
+           pattern struct-pat
+           obj-var obj-var
+           guard-chain ^(,*(if guard0 (list guard0)) ,guard1
+                         ,*(mappend .guard-chain all-matches))
+           test-expr ^(and ,*(mapcar .test-expr all-matches))
+           vars [mappend .vars all-matches]
+           var-exprs [mappend .var-exprs all-matches]))))
 
 (defun compile-var-match (sym obj-var)
   (or (null sym) (bindable sym)
diff --git a/txr.1 b/txr.1
index 8578ec3c..91f8af9d 100644
--- a/txr.1
+++ b/txr.1
@@ -39782,16 +39782,28 @@ against the corresponding vector element.
 .NP* Structure match
 .synb
 .mets @(structure << name >> { slot-name << pattern }*)
+.mets @(structure << pattern >> { slot-name << pattern }*)
 .syne
 .desc
-The structure pattern operator matches a structure object.
-The first argument of the pattern operator is a symbol which gives the name of
-the structure type. The corresponding object being matched must be a structure
-instance, and must be of this type, otherwise there is no match
+The structure pattern operator matches a structure object. The operator
+supports two modes of matching, the choice of which depends on whether the
+first argument is a
+.meta name
+or a
+.metn pattern .
+
+The first argument is considered a
+.meta name
+if it is a bindable symbol according to the
+.code bindable
+function. In this situation, the operator operates in
+strict mode.  Otherwise, the operator is in loose mode.
 
 The
 .meta name
-is followed by zero or more
+or
+.meta pattern
+argument is followed by zero or more
 .meta "slot-name pattern"
 pairs, which are not enclosed in lists, similarly to the way
 slots are presented in the
@@ -39800,11 +39812,39 @@ struct syntax and in the argument conventions of the
 .code new
 macro.
 
-Each
+In strict mode,
+.meta name
+is assumed to be the name of an existing struct type.
+The object being matched is tested whether it is a subtype of this type, as
+if using the
+.code subtypep
+function. If it isn't, the match fails.
+
+In loose mode, the object being matched is tested whether it is a structure
+object of any structure type. If it isn't, the match fails.
+
+In strict mode, each
 .meta "slot-name pattern"
 pair requires that the object's slot of that name contain
 a value which matches
 .metn pattern .
+The operator assumes that all the
+.metn slot-name -s
+are slots of the struct type indicated by
+.metn name .
+
+In loose mode, no assumption is made that the object actually has the
+slots specified by the
+.meta slot-name
+arguments. The object's structure type is inquired to
+determine whether it has each of those slots. If it doesn't, the match fails.
+If the object has the required slots, then the values of those slots are
+matched against the patterns.
+
+In loose mode, the
+.meta pattern
+given in the first argument position of the syntax is matched against the
+object's structure type: the type itself, rather than its symbolic name.
 
 .TP* Examples:
 
@@ -39815,6 +39855,25 @@ a value which matches
   (when-match @(struct time year 2021 month @m)
               #S(time year 2021 month 1)
     m) -> 1
+
+  ;; match any structure with name and value slots,
+  ;; whose name is foo, and extract the value.
+
+  (defstruct widget ()
+    name
+    value)
+
+  (defstruct grommet ()
+    name
+    value)
+
+  (append-each ((obj (list (new grommet name "foo" value :grom)
+                           (new widget name "foo" value :widg))))
+    (when-match @(struct @type name "foo" value @v) obj
+      (list (list type v))))
+
+  --> ((#<struct-type grommet> :grom)
+       (#<struct-type widget> :widg))
 .brev
 
 .SS* Quasiquote Operator Syntax